--- a/Filename.st Thu Nov 23 02:52:35 1995 +0100
+++ b/Filename.st Thu Nov 23 03:01:22 1995 +0100
@@ -14,7 +14,8 @@
instanceVariableNames:'nameString'
classVariableNames:'NextTempFilenameIndex'
poolDictionaries:''
- category:'System-Support'!
+ category:'System-Support'
+!
!Filename class methodsFor:'documentation'!
@@ -32,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Filename.st,v 1.41 1995-11-14 21:42:42 cg Exp $'
-!
-
documentation
"
Filenames; originally added for ST-80 compatibility, is
@@ -185,21 +182,14 @@
f edit
"
+!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Filename.st,v 1.42 1995-11-23 02:00:32 cg Exp $'
! !
!Filename class methodsFor:'instance creation'!
-named:aString
- "return a filename for a directory named aString.
- This is the same as 'aString asFilename'."
-
- ^ (self basicNew) setName:aString
-
- "
- Filename named:'/tmp/fooBar'
- "
-!
-
currentDirectory
"return a filename for the current directory"
@@ -230,6 +220,32 @@
"
!
+fromUser
+ "show a box to enter a filename. Return a filename instance or
+ nil (if cancel was pressed)."
+
+ |name|
+
+ name := FileSelectionBox requestFilename.
+ name notNil ifTrue:[^ self named:name].
+ ^ nil
+
+ "
+ Filename fromUser
+ "
+!
+
+named:aString
+ "return a filename for a directory named aString.
+ This is the same as 'aString asFilename'."
+
+ ^ (self basicNew) setName:aString
+
+ "
+ Filename named:'/tmp/fooBar'
+ "
+!
+
newTemporary
"return a new unique filename - use this for temporary files.
The filenames returned are '/tmp/stxtmp_xx_nn' where xx is our
@@ -311,70 +327,10 @@
"Modified: 7.9.1995 / 10:48:31 / claus"
"Modified: 4.11.1995 / 20:26:23 / cg"
-!
-
-fromUser
- "show a box to enter a filename. Return a filename instance or
- nil (if cancel was pressed)."
-
- |name|
-
- name := FileSelectionBox requestFilename.
- name notNil ifTrue:[^ self named:name].
- ^ nil
-
- "
- Filename fromUser
- "
! !
!Filename class methodsFor:'queries'!
-separator
- "return the file/directory separator.
- Usually, this is $/ for unix-like systems
- and $\ for dos-like ones (there may be more in the future)."
-
- ^ OperatingSystem fileSeparator
-
- "
- Filename separator
- "
-!
-
-suffixSeparator
- "return the filename suffix separator.
- Usually, this is $. for unix-like and msdos systems
- (there is currently no knowns system, where this differs)"
-
- ^ $.
-
- "
- Filename suffixSeparator
- "
-
- "Modified: 7.9.1995 / 11:10:43 / claus"
-!
-
-parentDirectoryName
- "return the name used for the parent directory.
- This is '..' for unix and dos-like systems.
- (there may be more in the future."
-
- ^ OperatingSystem parentDirectoryName
-
- "
- Filename parentDirectoryName
- "
-!
-
-isCaseSensitive
- "return true, if filenames are case sensitive.
- We ask the OS about this, to be independent here."
-
- ^ OperatingSystem caseSensitiveFilenames
-!
-
defaultClass
"ST-80 compatibility:
in ST-80, different subclasses of Filename are used for different
@@ -384,29 +340,6 @@
^ self
!
-localNameStringFrom:aString
- "ST-80 compatibility.
- what does this do ? (used in FileNavigator-goody).
- GUESS: does it strip off the voulume-character on MSDOS systems ?"
-
- (aString startsWith:'/') ifTrue:[
- ^ aString copyFrom:2
- ].
- ^ aString
-
- "Modified: 7.9.1995 / 10:44:56 / claus"
-!
-
-volumes
- "ST-80 compatibility.
- what does this do ? (used in FileNavigator-goody).
- GUESS: does it return the available drives on MSDOS systems ?"
-
- ^ #('/')
-
- "Modified: 7.9.1995 / 10:45:25 / claus"
-!
-
filenameCompletionFor:aString directory:inDirectory directoriesOnly:directoriesOnly filesOnly:filesOnly ifMultiple:aBlock
"perform filename completion on aString in some directory;
return the longest matching filename prefix as a string.
@@ -494,14 +427,154 @@
].
^ s
+!
+
+isCaseSensitive
+ "return true, if filenames are case sensitive.
+ We ask the OS about this, to be independent here."
+
+ ^ OperatingSystem caseSensitiveFilenames
+!
+
+localNameStringFrom:aString
+ "ST-80 compatibility.
+ what does this do ? (used in FileNavigator-goody).
+ GUESS: does it strip off the voulume-character on MSDOS systems ?"
+
+ (aString startsWith:'/') ifTrue:[
+ ^ aString copyFrom:2
+ ].
+ ^ aString
+
+ "Modified: 7.9.1995 / 10:44:56 / claus"
+!
+
+parentDirectoryName
+ "return the name used for the parent directory.
+ This is '..' for unix and dos-like systems.
+ (there may be more in the future."
+
+ ^ OperatingSystem parentDirectoryName
+
+ "
+ Filename parentDirectoryName
+ "
+!
+
+separator
+ "return the file/directory separator.
+ Usually, this is $/ for unix-like systems
+ and $\ for dos-like ones (there may be more in the future)."
+
+ ^ OperatingSystem fileSeparator
+
+ "
+ Filename separator
+ "
+!
+
+suffixSeparator
+ "return the filename suffix separator.
+ Usually, this is $. for unix-like and msdos systems
+ (there is currently no knowns system, where this differs)"
+
+ ^ $.
+
+ "
+ Filename suffixSeparator
+ "
+
+ "Modified: 7.9.1995 / 11:10:43 / claus"
+!
+
+volumes
+ "ST-80 compatibility.
+ what does this do ? (used in FileNavigator-goody).
+ GUESS: does it return the available drives on MSDOS systems ?"
+
+ ^ #('/')
+
+ "Modified: 7.9.1995 / 10:45:25 / claus"
+! !
+
+!Filename methodsFor:'comparing'!
+
+= aFilename
+ "return true, if the argument represents the same filename"
+
+ |str|
+
+ self species == aFilename species ifTrue:[
+ str := aFilename asString.
+ self class isCaseSensitive ifTrue:[
+ ^ nameString = str
+ ].
+ ^ nameString sameAs:str
+ ].
+ ^ false
+!
+
+hash
+ "return an integer useful as a hash-key"
+
+ ^ nameString hash
+! !
+
+!Filename methodsFor:'converting'!
+
+asAbsoluteFilename
+ "return the receiver converted to a filename with
+ an absolute pathname."
+
+ ^ self pathName asFilename
+!
+
+asFilename
+ "return the receiver converted to a filename."
+
+ "Thats pretty easy here :-)"
+ ^ self
+!
+
+asString
+ "return the receiver converted to a string"
+
+ ^ nameString
+!
+
+makeLegalFilename
+ "convert the receveivers name to be a legal filename.
+ The implementation may change in the future to be more
+ OS specific."
+
+ "
+ actually, in Unix spaces are allowed - but it makes life
+ so hard; therefore, replace them by underscores ...
+ "
+ nameString replaceAll:(Character space) by:$_.
+ "
+ need more - especially on SYS5.3 type systems,
+ we may want to contract the fileName to 14 characters.
+ "
+ ^ self
+
+ "
+ 'hello world' asFilename makeLegalFilename
+ "
! !
!Filename methodsFor:'error handling'!
-reportError:string with:filename
- ^ OperatingSystem errorSignal
+accessDeniedError:filename
+ ^ OperatingSystem accessDeniedErrorSignal
raiseRequestWith:filename
- errorString:string
+ errorString:('access denied: ' , filename asString)
+!
+
+fileCreationError:filename
+ ^ OperatingSystem accessDeniedErrorSignal
+ raiseRequestWith:filename
+ errorString:('cannot create/write file: ' , filename asString)
!
fileNotFoundError:filename
@@ -510,26 +583,465 @@
errorString:('file not found: ' , filename asString)
!
-fileCreationError:filename
- ^ OperatingSystem accessDeniedErrorSignal
- raiseRequestWith:filename
- errorString:('cannot create/write file: ' , filename asString)
-!
-
-accessDeniedError:filename
- ^ OperatingSystem accessDeniedErrorSignal
- raiseRequestWith:filename
- errorString:('access denied: ' , filename asString)
-!
-
removeError:filename
^ OperatingSystem accessDeniedErrorSignal
raiseRequestWith:filename
errorString:('cannot remove: ' , filename asString)
+!
+
+reportError:string with:filename
+ ^ OperatingSystem errorSignal
+ raiseRequestWith:filename
+ errorString:string
+! !
+
+!Filename methodsFor:'file access'!
+
+appendingWriteStream
+ "return a stream for appending to the file represented by the receiver.
+ If the file does not already exist, it is created."
+
+ ^ FileStream appendingOldFileNamed:nameString
+!
+
+newReadWriteStream
+ "return a stream for read/write the file represented by the receiver.
+ If the file does not already exist, it is created."
+
+ ^ FileStream newFileNamed:nameString
+!
+
+readStream
+ "return a stream for reading from the file represented by the receiver.
+ If the file does not already exist, nil is returned."
+
+ ^ FileStream readonlyFileNamed:nameString
+
+ "
+ '/tmp/foo' asFilename readStream
+ "
+!
+
+readWriteStream
+ "return a stream for read/write the file represented by the receiver.
+ If the file does not already exist, nil is returned."
+
+ ^ FileStream oldFileNamed:nameString
+!
+
+writeStream
+ "return a stream for writing to the file represented by the receiver.
+ If the file does not already exist, it is created."
+
+ ^ FileStream newFileForWritingNamed:nameString
+
+ "
+ '/tmp/foo' asFilename writeStream
+ "
+! !
+
+!Filename methodsFor:'file operations'!
+
+addAccessRights:aCollection
+ "add the access rights as specified in aCollection for the file represented
+ by the receiver. The argument must be a collection of symbols,
+ such as #readUser, #writeGroup etc."
+
+ |access|
+
+ access := OperatingSystem accessModeOf:nameString.
+ aCollection do:[:accessSymbol |
+ access := access bitOr:(OperatingSystem accessMaskFor:accessSymbol).
+ ].
+ (OperatingSystem changeAccessModeOf:nameString to:access) ifFalse:[
+ ^ self accessDeniedError:self
+ ]
+
+ "
+ 'foo' asFilename writeStream close.
+ 'foo' asFilename addAccessRights:#(readUser readGroup readOthers).
+ 'foo' asFilename addAccessRights:#(writeUser writeGroup writeOthers).
+ 'foo' asFilename addAccessRights:#(executeUser executeGroup executeOthers).
+ "
+!
+
+copyTo:newName
+ "copy the file - the argument must be convertable to a filename.
+ Return true if successfull, false if not."
+
+ |inStream outStream buffer bufferSize count newFile|
+
+ bufferSize := 8 * 1024.
+ buffer := ByteArray new:bufferSize.
+ inStream := self readStream.
+ inStream isNil ifTrue:[
+ ^ self fileNotFoundError:self
+ ].
+
+ outStream := (newFile := newName asFilename) writeStream.
+ outStream isNil ifTrue:[
+ ^ self fileCreationError:newFile
+ ].
+
+ [inStream atEnd] whileFalse:[
+ count := inStream nextBytes:bufferSize into:buffer.
+ (outStream nextPutBytes:count from:buffer) ~= count ifTrue:[
+ ^ self fileCreationError:newFile
+ ]
+ ].
+ outStream close.
+ inStream close.
+
+ "
+ 'Makefile' asFilename copyTo:'Makefile.foo'
+ 'smalltalk' asFilename copyTo:'/dev/null'
+ "
+!
+
+delete
+ "remove the file - same as remove, for ST-80 compatibility"
+
+ self remove
+!
+
+makeDirectory
+ "create a directory with the receivers name.
+ Return true if successfull, false if not."
+
+ (OperatingSystem createDirectory:nameString) ifFalse:[
+ ^ self fileCreationError:self
+ ]
+!
+
+makeReadable
+ "make the file readable for the owner - you must have permission to do so."
+
+ ^ self addAccessRights:#(readUser)
+!
+
+makeReadableForAll
+ "make the file readable for all - you must have permission to do so."
+
+ ^ self addAccessRights:#(readUser readGroup readOthers)
+!
+
+makeUnwritable
+ "make the file unwritable for all - you must have permission to do so."
+
+ ^ self removeAccessRights:#(writeUser writeGroup writeOthers)
+!
+
+makeWritable
+ "make the file writableable for all - you must have permission to do so."
+
+ ^ self addAccessRights:#(writeUser)
+!
+
+makeWritableForAll
+ "make the file writable for all - you must have permission to do so."
+
+ ^ self addAccessRights:#(writeUser writeGroup writeOthers)
+!
+
+moveTo:newName
+ "copy the file represented by the receiver, then delete it.
+ This is different to renaming in case of cross device moves.
+ Return true if successfull, false if not."
+
+ self copyTo:newName.
+ self remove
+!
+
+recursiveRemove
+ "remove the directory and all of its subfiles/subdirectories."
+
+ |ok|
+
+ ok := OperatingSystem recursiveRemoveDirectory:nameString.
+ ok ifFalse:[
+ self removeError:self
+ ].
+
+ "
+ 'foo' asFilename makeDirectory.
+ 'foo/bar' asFilename writeStream close.
+ ('foo' asFilename remove) ifFalse:[
+ Transcript showCr:'could not remove foo'
+ ]
+ "
+ "
+ 'foo' asFilename makeDirectory.
+ 'foo/bar' asFilename writeStream close.
+ ('foo' asFilename recursiveRemove) ifFalse:[
+ Transcript showCr:'could not remove foo'
+ ]
+ "
+
+ "Created: 14.11.1995 / 11:19:29 / cg"
+!
+
+remove
+ "remove the file/directory - the argument must be convertable to a String.
+ Return true if sucessfull, false if not.
+ Use recursiveRemove in order to (recursively) remove non empty directories."
+
+ |ok|
+
+ self exists ifFalse:[ ^ self].
+ self isDirectory ifTrue:[
+ ok := OperatingSystem removeDirectory:nameString
+ ] ifFalse:[
+ ok := OperatingSystem removeFile:nameString
+ ].
+ ok ifFalse:[
+ self removeError:self
+ ].
+
+ "
+ (FileStream newFileNamed:'foo') close.
+ 'foo' asFilename remove
+ "
+
+ "
+ 'foo' asFilename makeDirectory.
+ 'foo/bar' asFilename writeStream close.
+ ('foo' asFilename remove) ifFalse:[
+ Transcript showCr:'could not remove foo'
+ ]
+ "
+
+ "Modified: 14.11.1995 / 11:18:26 / cg"
+!
+
+removeAccessRights:aCollection
+ "remove the access rights as specified in aCollection for the file represented
+ by the receiver. The argument must be a collection of symbols,
+ such as #readUser, #writeGroup etc."
+
+ |access|
+
+ access := OperatingSystem accessModeOf:nameString.
+ aCollection do:[:accessSymbol |
+ access := access bitAnd:(OperatingSystem accessMaskFor:accessSymbol) bitInvert.
+ ].
+ (OperatingSystem changeAccessModeOf:nameString to:access) ifFalse:[
+ ^ self accessDeniedError:self
+ ].
+
+ "
+ 'foo' asFilename writeStream close.
+ 'foo' asFilename removeAccessRights:#(readUser readGroup readOthers).
+ 'foo' asFilename removeAccessRights:#(writeUser writeGroup writeOthers).
+ 'foo' asFilename removeAccessRights:#(executeUser executeGroup executeOthers).
+ "
+!
+
+renameTo:newName
+ "rename the file - the argument must be convertable to a String."
+
+ |ok|
+
+ ok := OperatingSystem renameFile:nameString to:(newName asString).
+ ok ifFalse:[
+ self exists ifFalse:[
+ ^ self fileNotFoundError:self
+ ].
+ ^ self accessDeniedError:newName asFilename.
+ ].
+
+ "
+ '/tmp/foo' asFilename renameTo:'/tmp/bar'
+ "
+! !
+
+!Filename methodsFor:'file queries'!
+
+dates
+ "return the files modification and access times as an object (currently a dictionary)
+ that responds to the at: message with arguments
+ #modified, #accessed or #statusChanged."
+
+ |info dates|
+
+ info := OperatingSystem infoOf:nameString.
+ info isNil ifTrue:[
+ info := OperatingSystem linkInfoOf:nameString.
+ info isNil ifTrue:[
+ ^ nil
+ ]
+ ].
+ dates := IdentityDictionary new.
+ dates at:#modified put:(info at:#modified).
+ dates at:#accessed put:(info at:#accessed).
+ dates at:#statusChanged put:(info at:#statusChanged).
+ ^ dates
+
+ "
+ Filename currentDirectory dates
+ '../regression' asFilename dates
+ "
+!
+
+fileSize
+ "return the size of the file in bytes"
+
+ |info|
+
+ info := self info.
+ info isNil ifTrue:[^ nil].
+ ^ info at:#size
+!
+
+fileType
+ "this returns a string describing the type of contents of
+ the file. This is done using the unix 'file' command,
+ (which usually is configurable by /etc/magic).
+ On non-unix systems, this may return an empty string, not knowning
+ about the contents."
+
+ |stream typeString|
+
+ typeString := ''.
+ stream := PipeStream readingFrom:('file ' , self pathName).
+ stream notNil ifTrue:[
+ typeString := stream contents asString.
+ stream close.
+ typeString := typeString copyFrom:(typeString indexOf:$:) + 1.
+ typeString := typeString withoutSeparators
+ ] ifFalse:[
+ "
+ could add some fallback code here, for systems, where no
+ file command is avaliable ...
+ ... or at least analyze directory info.
+ "
+ ].
+ ^ typeString
+
+ "
+ 'Makefile' asFilename fileType
+ '.' asFilename fileType
+ '/dev/null' asFilename fileType
+ 'smalltalk.rc' asFilename fileType
+ 'bitmaps/SBrowser.xbm' asFilename fileType
+ "
+!
+
+info
+ "return the files info; that is a collection of file attributes,
+ (actually a dictionary) where the keys are #type, #uid, #gid, #size etc.
+ The actual amount and detail returned may depend on the OS used.
+ On unix, if you ask for the info of a symbolic link, the target
+ files info is returned. (see also: #linkInfo)
+
+ On unix, the contents is:
+ id -> the inode number (integer)
+ uid -> the numeric user id of the files owner
+ gid -> the numeric group id of the files owner
+ statusChanged -> the absoluteTime when the files status changed last
+ (i.e. protection change, owner change etc.)
+ accessed -> the absoluteTime when the file was last accessed
+ modified -> the absoluteTime when the file was last modified
+ size -> the size (in bytes) of the file
+ type -> the files type (#regular, #directory, #characterSpecial)
+ mode -> the files access protection bits (rwxrwxrwx mask).
+
+ The minimum returned info (i.e. on all OS's) will consist of at least:
+ modified
+ size
+ type
+
+ Some OS's (VMS) may return more info.
+
+ Dont expect things like uid/gid/mode to be there; write your application
+ to either handle the cases where info-entries are not present,
+ or (better) use one of isXXXX query methods. (Be prepared for DOS ...)
+ "
+
+ ^ OperatingSystem infoOf:nameString
+
+ "
+ Filename currentDirectory info
+ '/dev/null' asFilename info
+ 'Make.proto' asFilename info
+ 'source/Point.st' asFilename info
+ 'source/Point.st' asFilename linkInfo
+ '../../libbasic/Point.st' asFilename info
+ "
+!
+
+linkInfo
+ "return the files info if its a symbolic link; nil otherwise.
+ On OS's which do not support symbolic links, nil is always returned.
+ The information is the same as returned by #info, except that if the
+ receiver represents a symbolic link, the links information
+ is returned
+ (while in this case, #info returns the info of the target file,
+ which is accessed via the symbolic link).
+
+ In addition to the normal entries, Unix returns an additional entry:
+ path -> the target files pathname
+
+ See the comment in #info for more details."
+
+ ^ OperatingSystem linkInfoOf:nameString
+
+ "
+ Filename currentDirectory linkInfo
+ '/dev/null' asFilename linkInfo
+ 'Make.proto' asFilename linkInfo
+ 'Make.proto' asFilename linkInfo at:#path
+ 'source/Point.st' asFilename linkInfo
+ '../../libbasic/Point.st' asFilename linkInfo
+ "
+! !
+
+!Filename methodsFor:'file utilities'!
+
+contentsOfEntireFile
+ "return the contents of the file as a string"
+
+ |s contents|
+
+ s := self readStream.
+ [
+ contents := s contents
+ ] valueNowOrOnUnwindDo:[s close].
+ ^ contents
+!
+
+edit
+ "start an editView on the file represented by the receiver"
+
+ EditTextView openOn:self asString
+
+ "
+ 'smalltalk.rc' asFilename edit
+ "
+!
+
+fileIn
+ "load smalltalk code from the file"
+
+ ^ self readStream fileIn
! !
!Filename methodsFor:'instance creation'!
+construct:subname
+ "taking the receiver as a directory name, construct a new
+ filename for an entry within this directory (i.e. for a file
+ or a subdirectory in that directory)."
+
+ ^ (self constructString:subname) asFilename
+
+ "
+ '/tmp' asFilename construct:'foo'
+ '/' asFilename construct:'foo'
+ '/usr/tmp' asFilename construct:'foo'
+ '/foo/bar' asFilename construct:'baz'
+ "
+!
+
constructString:subname
"taking the receiver as a directory name, construct a new
filenames string for an entry within this directory (i.e. for a file
@@ -552,21 +1064,6 @@
"
"Modified: 7.9.1995 / 10:15:22 / claus"
-!
-
-construct:subname
- "taking the receiver as a directory name, construct a new
- filename for an entry within this directory (i.e. for a file
- or a subdirectory in that directory)."
-
- ^ (self constructString:subname) asFilename
-
- "
- '/tmp' asFilename construct:'foo'
- '/' asFilename construct:'foo'
- '/usr/tmp' asFilename construct:'foo'
- '/foo/bar' asFilename construct:'baz'
- "
! !
!Filename methodsFor:'misc'!
@@ -585,70 +1082,23 @@
"
! !
-!Filename methodsFor:'comparing'!
-
-hash
- "return an integer useful as a hash-key"
-
- ^ nameString hash
-!
-
-= aFilename
- "return true, if the argument represents the same filename"
-
- |str|
+!Filename methodsFor:'printing & storing'!
- self species == aFilename species ifTrue:[
- str := aFilename asString.
- self class isCaseSensitive ifTrue:[
- ^ nameString = str
- ].
- ^ nameString sameAs:str
- ].
- ^ false
-! !
+printOn:aStream
+ "append a printed representation of the receiver to aStream."
-!Filename methodsFor:'converting'!
-
-asString
- "return the receiver converted to a string"
-
- ^ nameString
+ aStream nextPutAll:'FileName('''.
+ nameString printOn:aStream.
+ aStream nextPutAll:''')'
!
-asFilename
- "return the receiver converted to a filename."
-
- "Thats pretty easy here :-)"
- ^ self
-!
-
-asAbsoluteFilename
- "return the receiver converted to a filename with
- an absolute pathname."
-
- ^ self pathName asFilename
-!
+storeOn:aStream
+ "append a printed representation of the receiver to aStream,
+ which allows reconstructing it via readFrom:"
-makeLegalFilename
- "convert the receveivers name to be a legal filename.
- The implementation may change in the future to be more
- OS specific."
-
- "
- actually, in Unix spaces are allowed - but it makes life
- so hard; therefore, replace them by underscores ...
- "
- nameString replaceAll:(Character space) by:$_.
- "
- need more - especially on SYS5.3 type systems,
- we may want to contract the fileName to 14 characters.
- "
- ^ self
-
- "
- 'hello world' asFilename makeLegalFilename
- "
+ aStream nextPut:$(.
+ nameString storeOn:aStream.
+ aStream nextPutAll:' asFilename)'
! !
!Filename methodsFor:'private accessing'!
@@ -661,51 +1111,33 @@
!Filename methodsFor:'queries'!
-separator
- "return the directory-separator character (or string)"
-
- ^ self class separator
-!
+baseName
+ "return my baseName as a string.
+ - thats the file/directory name without leading parent-dirs."
-directoryPathName
- "return the full directory pathname part of the file/directory as a string.
- - thats the full pathname of the directory where the file/dir represented by
- the receiver is contained in.
- See also: directoryName"
-
- ^ OperatingSystem directoryNameOf:(self pathName)
+ ^ OperatingSystem baseNameOf:nameString "/ (self pathName)
"
- '/foo/bar/' asFilename directoryPathName
- '/foo/bar' asFilename directoryPathName
- '.' asFilename directoryPathName
- '..' asFilename directoryPathName
- '../..' asFilename directoryPathName
+ '/foo/bar' asFilename baseName
+ '.' asFilename baseName
+ '..' asFilename baseName
+ '../..' asFilename baseName
+ '../../libbasic' asFilename baseName
+ '../../libpr' asFilename baseName
+ '../../libbasic/Object.st' asFilename baseName
"
-
- "Modified: 7.9.1995 / 10:42:13 / claus"
!
-directoryName
- "return the directory name part of the file/directory as a string.
- - thats the name of the directory where the file/dir represented by
- the receiver is contained in.
- See also: #directoryPathName"
+canBeWritten
+ "same as isWritable - for ST-80 compatibility"
- ^ OperatingSystem directoryNameOf:nameString "/ (self pathName)
+ ^ self isWritable
"
- '/foo/bar/' asFilename directoryName
- '/foo/bar' asFilename directoryName
- 'bitmaps' asFilename directoryName
- 'bitmaps' asFilename directoryPathName
- '.' asFilename directoryName
- '..' asFilename directoryName
- '../..' asFilename directoryName
- '../..' asFilename directoryPathName
+ '/foo/bar' asFilename canBeWritten
+ '/tmp' asFilename canBeWritten
+ 'Makefile' asFilename canBeWritten
"
-
- "Modified: 7.9.1995 / 10:42:03 / claus"
!
directory
@@ -733,112 +1165,45 @@
"
!
-tail
- "the files name without directory prefix as a string.
- An alias for baseName, for ST-80 compatiblity."
+directoryName
+ "return the directory name part of the file/directory as a string.
+ - thats the name of the directory where the file/dir represented by
+ the receiver is contained in.
+ See also: #directoryPathName"
- ^ self baseName
-!
-
-baseName
- "return my baseName as a string.
- - thats the file/directory name without leading parent-dirs."
-
- ^ OperatingSystem baseNameOf:nameString "/ (self pathName)
+ ^ OperatingSystem directoryNameOf:nameString "/ (self pathName)
"
- '/foo/bar' asFilename baseName
- '.' asFilename baseName
- '..' asFilename baseName
- '../..' asFilename baseName
- '../../libbasic' asFilename baseName
- '../../libpr' asFilename baseName
- '../../libbasic/Object.st' asFilename baseName
- "
-!
-
-name
- "return the name of the file represented by the receiver as a string.
- This may or may not be a relative name.
- See also: pathName"
-
- self isAbsolute ifTrue:[^ self pathName].
- ^ nameString
-
- "
- '/foo/bar' asFilename name
- '/foo/bar' asFilename pathName
- '.' asFilename name
- '.' asFilename pathName
- '../..' asFilename name
- '../..' asFilename pathName
- 'bitmaps' asFilename name
- 'bitmaps' asFilename pathName
- '/tmp/../usr' asFilename name
- '/tmp/../usr' asFilename pathName
+ '/foo/bar/' asFilename directoryName
+ '/foo/bar' asFilename directoryName
+ 'bitmaps' asFilename directoryName
+ 'bitmaps' asFilename directoryPathName
+ '.' asFilename directoryName
+ '..' asFilename directoryName
+ '../..' asFilename directoryName
+ '../..' asFilename directoryPathName
"
- "Modified: 7.9.1995 / 10:41:14 / claus"
+ "Modified: 7.9.1995 / 10:42:03 / claus"
!
-pathName
- "return the full pathname of the file represented by the receiver,
- as a string. See also: name"
-
- |parentName sep|
+directoryPathName
+ "return the full directory pathname part of the file/directory as a string.
+ - thats the full pathname of the directory where the file/dir represented by
+ the receiver is contained in.
+ See also: directoryName"
- sep := self class separator.
- (nameString startsWith:sep) ifTrue:[
- parentName := self class parentDirectoryName.
- (nameString findString:parentName) == 0 ifTrue:[
- ^ nameString
- ]
- ].
- ^ (FileDirectory directoryNamed:nameString) pathName
+ ^ OperatingSystem directoryNameOf:(self pathName)
"
- '/foo/bar' asFilename pathName
- '.' asFilename pathName
- '../..' asFilename pathName
- '../..' asFilename name
- '/tmp/../usr' asFilename pathName
+ '/foo/bar/' asFilename directoryPathName
+ '/foo/bar' asFilename directoryPathName
+ '.' asFilename directoryPathName
+ '..' asFilename directoryPathName
+ '../..' asFilename directoryPathName
"
- "Modified: 7.9.1995 / 10:42:39 / claus"
-!
-
-isAbsolute
- "return true, if the receiver represents an absolute pathname
- (in contrast to one relative to the current directory)."
-
- ^ (nameString startsWith:self class separator)
-
- "
- '/foo/bar' asFilename isAbsolute
- '..' asFilename isAbsolute
- '..' asAbsoluteFilename isAbsolute
- 'source/SBrowser.st' asFilename isAbsolute
- "
-!
-
-isRelative
- "return true, if this name is interpreted relative to some
- directory (opposite of absolute)"
-
- ^ self isAbsolute not
-!
-
-isDirectory
- "return true, if the receiver represents an existing,
- readable directories pathname."
-
- ^ OperatingSystem isDirectory:nameString
-
- "
- '/foo/bar' asFilename isDirectory
- '/tmp' asFilename isDirectory
- 'Makefile' asFilename isDirectory
- "
+ "Modified: 7.9.1995 / 10:42:13 / claus"
!
exists
@@ -853,143 +1218,6 @@
"
!
-isReadable
- "return true, if such a file exists and is readable."
-
- ^ OperatingSystem isReadable:nameString
-
- "
- '/foo/bar' asFilename isReadable
- '/tmp' asFilename isReadable
- 'Makefile' asFilename isReadable
- "
-!
-
-canBeWritten
- "same as isWritable - for ST-80 compatibility"
-
- ^ self isWritable
-
- "
- '/foo/bar' asFilename canBeWritten
- '/tmp' asFilename canBeWritten
- 'Makefile' asFilename canBeWritten
- "
-!
-
-isWritable
- "return true, if such a file exists and is writable."
-
- ^ OperatingSystem isWritable:nameString
-
- "
- '/foo/bar' asFilename isWritable
- '/tmp' asFilename isWritable
- 'Makefile' asFilename isWritable
- "
-!
-
-isExecutable
- "return true, if such a file exists and is executable (by Unix's definition).
- For directories, true is returned if the directory can be entered.
- See isExecutableProgram for a related check."
-
- ^ OperatingSystem isExecutable:nameString
-
- "
- '/foo/bar' asFilename isExecutable
- '/tmp' asFilename isExecutable
- 'Makefile' asFilename isExecutable
- '/bin/ls' asFilename isExecutable
- "
-!
-
-isExecutableProgram
- "return true, if such a file exists and is an executable program.
- (i.e. for directories, false is returned.)"
-
- ^ (OperatingSystem isExecutable:nameString)
- and:[(OperatingSystem isDirectory:nameString) not]
-
- "
- '/tmp' asFilename isExecutable
- '/bin/ls' asFilename isExecutable
- '/tmp' asFilename isExecutableProgram
- '/bin/ls' asFilename isExecutableProgram
- "
-!
-
-isSymbolicLink
- "return true, if the file represented by the receiver is a symbolic
- link. Notice that not all OS's support symbolic links; those that do
- not will always return false."
-
- ^ OperatingSystem isSymbolicLink:nameString
-
- "
- 'Make.proto' asFilename isSymbolicLink
- 'Makefile' asFilename isSymbolicLink
- "
-!
-
-prefixAndSuffix
- "return an array consisting of my prefix and suffix.
- The suffix is the namepart after the final period character,
- the prefix everything before, except for the period.
- (on some systems, the suffix-character may be different from a period).
- For example, foo.bar.baz has a prefix of 'foo.bar' and a suffix of '.baz'.
-
- Notice: there is currently no known system which uses other than
- the period character as suffixCharacter."
-
- |nm idx|
-
- nm := self baseName.
- idx := nm lastIndexOf:(self class suffixSeparator).
- idx == 0 ifTrue:[
- ^ Array with:nm with:''
- ].
- ^ Array
- with:(nm copyTo:idx-1)
- with:(nm copyFrom:idx+1)
-
- "
- 'abc.st' asFilename prefixAndSuffix
- 'abc' asFilename prefixAndSuffix
- 'a.b.c' asFilename prefixAndSuffix
-
- |parts|
- parts := 'Object.st' asFilename prefixAndSuffix.
- ((parts at:1) , '.o') asFilename
- "
-
- "Modified: 7.9.1995 / 11:15:42 / claus"
-!
-
-suffix
- "return my suffix.
- The suffix is the namepart after the final period character,
- or the empty string, if the name does not contain a period."
-
- ^ self prefixAndSuffix at:2
-
- "
- 'abc.st' asFilename suffix
- 'abc' asFilename suffix
- 'a.b.c' asFilename suffix
- "
-
- "Modified: 7.9.1995 / 11:09:03 / claus"
-!
-
-filesMatching:aPattern
- ^ self directoryContents select:[:name | aPattern match:name]
-
- "
- Filename currentDirectory filesMatching:'M*'
- "
-!
-
filenameCompletion
"try to complete the recevier filename.
This method has both a return value and a side effect on the receiver:
@@ -1129,453 +1357,227 @@
'/u' asFilename filenameCompletion
'../../libpr' asFilename filenameCompletion
"
-! !
-
-!Filename methodsFor:'file queries'!
+!
-info
- "return the files info; that is a collection of file attributes,
- (actually a dictionary) where the keys are #type, #uid, #gid, #size etc.
- The actual amount and detail returned may depend on the OS used.
- On unix, if you ask for the info of a symbolic link, the target
- files info is returned. (see also: #linkInfo)
+filesMatching:aPattern
+ ^ self directoryContents select:[:name | aPattern match:name]
- On unix, the contents is:
- id -> the inode number (integer)
- uid -> the numeric user id of the files owner
- gid -> the numeric group id of the files owner
- statusChanged -> the absoluteTime when the files status changed last
- (i.e. protection change, owner change etc.)
- accessed -> the absoluteTime when the file was last accessed
- modified -> the absoluteTime when the file was last modified
- size -> the size (in bytes) of the file
- type -> the files type (#regular, #directory, #characterSpecial)
- mode -> the files access protection bits (rwxrwxrwx mask).
+ "
+ Filename currentDirectory filesMatching:'M*'
+ "
+!
- The minimum returned info (i.e. on all OS's) will consist of at least:
- modified
- size
- type
-
- Some OS's (VMS) may return more info.
+isAbsolute
+ "return true, if the receiver represents an absolute pathname
+ (in contrast to one relative to the current directory)."
- Dont expect things like uid/gid/mode to be there; write your application
- to either handle the cases where info-entries are not present,
- or (better) use one of isXXXX query methods. (Be prepared for DOS ...)
- "
-
- ^ OperatingSystem infoOf:nameString
+ ^ (nameString startsWith:self class separator)
"
- Filename currentDirectory info
- '/dev/null' asFilename info
- 'Make.proto' asFilename info
- 'source/Point.st' asFilename info
- 'source/Point.st' asFilename linkInfo
- '../../libbasic/Point.st' asFilename info
+ '/foo/bar' asFilename isAbsolute
+ '..' asFilename isAbsolute
+ '..' asAbsoluteFilename isAbsolute
+ 'source/SBrowser.st' asFilename isAbsolute
+ "
+!
+
+isDirectory
+ "return true, if the receiver represents an existing,
+ readable directories pathname."
+
+ ^ OperatingSystem isDirectory:nameString
+
+ "
+ '/foo/bar' asFilename isDirectory
+ '/tmp' asFilename isDirectory
+ 'Makefile' asFilename isDirectory
+ "
+!
+
+isExecutable
+ "return true, if such a file exists and is executable (by Unix's definition).
+ For directories, true is returned if the directory can be entered.
+ See isExecutableProgram for a related check."
+
+ ^ OperatingSystem isExecutable:nameString
+
+ "
+ '/foo/bar' asFilename isExecutable
+ '/tmp' asFilename isExecutable
+ 'Makefile' asFilename isExecutable
+ '/bin/ls' asFilename isExecutable
"
!
-linkInfo
- "return the files info if its a symbolic link; nil otherwise.
- On OS's which do not support symbolic links, nil is always returned.
- The information is the same as returned by #info, except that if the
- receiver represents a symbolic link, the links information
- is returned
- (while in this case, #info returns the info of the target file,
- which is accessed via the symbolic link).
+isExecutableProgram
+ "return true, if such a file exists and is an executable program.
+ (i.e. for directories, false is returned.)"
- In addition to the normal entries, Unix returns an additional entry:
- path -> the target files pathname
-
- See the comment in #info for more details."
-
- ^ OperatingSystem linkInfoOf:nameString
+ ^ (OperatingSystem isExecutable:nameString)
+ and:[(OperatingSystem isDirectory:nameString) not]
"
- Filename currentDirectory linkInfo
- '/dev/null' asFilename linkInfo
- 'Make.proto' asFilename linkInfo
- 'Make.proto' asFilename linkInfo at:#path
- 'source/Point.st' asFilename linkInfo
- '../../libbasic/Point.st' asFilename linkInfo
+ '/tmp' asFilename isExecutable
+ '/bin/ls' asFilename isExecutable
+ '/tmp' asFilename isExecutableProgram
+ '/bin/ls' asFilename isExecutableProgram
+ "
+!
+
+isReadable
+ "return true, if such a file exists and is readable."
+
+ ^ OperatingSystem isReadable:nameString
+
+ "
+ '/foo/bar' asFilename isReadable
+ '/tmp' asFilename isReadable
+ 'Makefile' asFilename isReadable
"
!
-dates
- "return the files modification and access times as an object (currently a dictionary)
- that responds to the at: message with arguments
- #modified, #accessed or #statusChanged."
+isRelative
+ "return true, if this name is interpreted relative to some
+ directory (opposite of absolute)"
- |info dates|
+ ^ self isAbsolute not
+!
- info := OperatingSystem infoOf:nameString.
- info isNil ifTrue:[
- info := OperatingSystem linkInfoOf:nameString.
- info isNil ifTrue:[
- ^ nil
- ]
- ].
- dates := IdentityDictionary new.
- dates at:#modified put:(info at:#modified).
- dates at:#accessed put:(info at:#accessed).
- dates at:#statusChanged put:(info at:#statusChanged).
- ^ dates
+isSymbolicLink
+ "return true, if the file represented by the receiver is a symbolic
+ link. Notice that not all OS's support symbolic links; those that do
+ not will always return false."
+
+ ^ OperatingSystem isSymbolicLink:nameString
"
- Filename currentDirectory dates
- '../regression' asFilename dates
+ 'Make.proto' asFilename isSymbolicLink
+ 'Makefile' asFilename isSymbolicLink
+ "
+!
+
+isWritable
+ "return true, if such a file exists and is writable."
+
+ ^ OperatingSystem isWritable:nameString
+
+ "
+ '/foo/bar' asFilename isWritable
+ '/tmp' asFilename isWritable
+ 'Makefile' asFilename isWritable
"
!
-fileSize
- "return the size of the file in bytes"
-
- |info|
-
- info := self info.
- info isNil ifTrue:[^ nil].
- ^ info at:#size
-!
-
-fileType
- "this returns a string describing the type of contents of
- the file. This is done using the unix 'file' command,
- (which usually is configurable by /etc/magic).
- On non-unix systems, this may return an empty string, not knowning
- about the contents."
+name
+ "return the name of the file represented by the receiver as a string.
+ This may or may not be a relative name.
+ See also: pathName"
- |stream typeString|
-
- typeString := ''.
- stream := PipeStream readingFrom:('file ' , self pathName).
- stream notNil ifTrue:[
- typeString := stream contents asString.
- stream close.
- typeString := typeString copyFrom:(typeString indexOf:$:) + 1.
- typeString := typeString withoutSeparators
- ] ifFalse:[
- "
- could add some fallback code here, for systems, where no
- file command is avaliable ...
- ... or at least analyze directory info.
- "
- ].
- ^ typeString
+ self isAbsolute ifTrue:[^ self pathName].
+ ^ nameString
"
- 'Makefile' asFilename fileType
- '.' asFilename fileType
- '/dev/null' asFilename fileType
- 'smalltalk.rc' asFilename fileType
- 'bitmaps/SBrowser.xbm' asFilename fileType
- "
-! !
-
-!Filename methodsFor:'file operations'!
-
-delete
- "remove the file - same as remove, for ST-80 compatibility"
-
- self remove
-!
-
-remove
- "remove the file/directory - the argument must be convertable to a String.
- Return true if sucessfull, false if not.
- Use recursiveRemove in order to (recursively) remove non empty directories."
-
- |ok|
-
- self exists ifFalse:[ ^ self].
- self isDirectory ifTrue:[
- ok := OperatingSystem removeDirectory:nameString
- ] ifFalse:[
- ok := OperatingSystem removeFile:nameString
- ].
- ok ifFalse:[
- self removeError:self
- ].
-
- "
- (FileStream newFileNamed:'foo') close.
- 'foo' asFilename remove
+ '/foo/bar' asFilename name
+ '/foo/bar' asFilename pathName
+ '.' asFilename name
+ '.' asFilename pathName
+ '../..' asFilename name
+ '../..' asFilename pathName
+ 'bitmaps' asFilename name
+ 'bitmaps' asFilename pathName
+ '/tmp/../usr' asFilename name
+ '/tmp/../usr' asFilename pathName
"
- "
- 'foo' asFilename makeDirectory.
- 'foo/bar' asFilename writeStream close.
- ('foo' asFilename remove) ifFalse:[
- Transcript showCr:'could not remove foo'
- ]
- "
-
- "Modified: 14.11.1995 / 11:18:26 / cg"
+ "Modified: 7.9.1995 / 10:41:14 / claus"
!
-recursiveRemove
- "remove the directory and all of its subfiles/subdirectories."
-
- |ok|
+pathName
+ "return the full pathname of the file represented by the receiver,
+ as a string. See also: name"
- ok := OperatingSystem recursiveRemoveDirectory:nameString.
- ok ifFalse:[
- self removeError:self
- ].
+ |parentName sep|
- "
- 'foo' asFilename makeDirectory.
- 'foo/bar' asFilename writeStream close.
- ('foo' asFilename remove) ifFalse:[
- Transcript showCr:'could not remove foo'
- ]
- "
- "
- 'foo' asFilename makeDirectory.
- 'foo/bar' asFilename writeStream close.
- ('foo' asFilename recursiveRemove) ifFalse:[
- Transcript showCr:'could not remove foo'
- ]
- "
-
- "Created: 14.11.1995 / 11:19:29 / cg"
-!
-
-renameTo:newName
- "rename the file - the argument must be convertable to a String."
-
- |ok|
-
- ok := OperatingSystem renameFile:nameString to:(newName asString).
- ok ifFalse:[
- self exists ifFalse:[
- ^ self fileNotFoundError:self
- ].
- ^ self accessDeniedError:newName asFilename.
+ sep := self class separator.
+ (nameString startsWith:sep) ifTrue:[
+ parentName := self class parentDirectoryName.
+ (nameString findString:parentName) == 0 ifTrue:[
+ ^ nameString
+ ]
].
+ ^ (FileDirectory directoryNamed:nameString) pathName
"
- '/tmp/foo' asFilename renameTo:'/tmp/bar'
+ '/foo/bar' asFilename pathName
+ '.' asFilename pathName
+ '../..' asFilename pathName
+ '../..' asFilename name
+ '/tmp/../usr' asFilename pathName
"
-!
-
-copyTo:newName
- "copy the file - the argument must be convertable to a filename.
- Return true if successfull, false if not."
-
- |inStream outStream buffer bufferSize count newFile|
-
- bufferSize := 8 * 1024.
- buffer := ByteArray new:bufferSize.
- inStream := self readStream.
- inStream isNil ifTrue:[
- ^ self fileNotFoundError:self
- ].
-
- outStream := (newFile := newName asFilename) writeStream.
- outStream isNil ifTrue:[
- ^ self fileCreationError:newFile
- ].
- [inStream atEnd] whileFalse:[
- count := inStream nextBytes:bufferSize into:buffer.
- (outStream nextPutBytes:count from:buffer) ~= count ifTrue:[
- ^ self fileCreationError:newFile
- ]
- ].
- outStream close.
- inStream close.
-
- "
- 'Makefile' asFilename copyTo:'Makefile.foo'
- 'smalltalk' asFilename copyTo:'/dev/null'
- "
-!
-
-moveTo:newName
- "copy the file represented by the receiver, then delete it.
- This is different to renaming in case of cross device moves.
- Return true if successfull, false if not."
-
- self copyTo:newName.
- self remove
+ "Modified: 7.9.1995 / 10:42:39 / claus"
!
-makeDirectory
- "create a directory with the receivers name.
- Return true if successfull, false if not."
+prefixAndSuffix
+ "return an array consisting of my prefix and suffix.
+ The suffix is the namepart after the final period character,
+ the prefix everything before, except for the period.
+ (on some systems, the suffix-character may be different from a period).
+ For example, foo.bar.baz has a prefix of 'foo.bar' and a suffix of '.baz'.
- (OperatingSystem createDirectory:nameString) ifFalse:[
- ^ self fileCreationError:self
- ]
-!
+ Notice: there is currently no known system which uses other than
+ the period character as suffixCharacter."
-addAccessRights:aCollection
- "add the access rights as specified in aCollection for the file represented
- by the receiver. The argument must be a collection of symbols,
- such as #readUser, #writeGroup etc."
-
- |access|
+ |nm idx|
- access := OperatingSystem accessModeOf:nameString.
- aCollection do:[:accessSymbol |
- access := access bitOr:(OperatingSystem accessMaskFor:accessSymbol).
+ nm := self baseName.
+ idx := nm lastIndexOf:(self class suffixSeparator).
+ idx == 0 ifTrue:[
+ ^ Array with:nm with:''
].
- (OperatingSystem changeAccessModeOf:nameString to:access) ifFalse:[
- ^ self accessDeniedError:self
- ]
+ ^ Array
+ with:(nm copyTo:idx-1)
+ with:(nm copyFrom:idx+1)
"
- 'foo' asFilename writeStream close.
- 'foo' asFilename addAccessRights:#(readUser readGroup readOthers).
- 'foo' asFilename addAccessRights:#(writeUser writeGroup writeOthers).
- 'foo' asFilename addAccessRights:#(executeUser executeGroup executeOthers).
+ 'abc.st' asFilename prefixAndSuffix
+ 'abc' asFilename prefixAndSuffix
+ 'a.b.c' asFilename prefixAndSuffix
+
+ |parts|
+ parts := 'Object.st' asFilename prefixAndSuffix.
+ ((parts at:1) , '.o') asFilename
"
+
+ "Modified: 7.9.1995 / 11:15:42 / claus"
!
-removeAccessRights:aCollection
- "remove the access rights as specified in aCollection for the file represented
- by the receiver. The argument must be a collection of symbols,
- such as #readUser, #writeGroup etc."
-
- |access|
+separator
+ "return the directory-separator character (or string)"
- access := OperatingSystem accessModeOf:nameString.
- aCollection do:[:accessSymbol |
- access := access bitAnd:(OperatingSystem accessMaskFor:accessSymbol) bitInvert.
- ].
- (OperatingSystem changeAccessModeOf:nameString to:access) ifFalse:[
- ^ self accessDeniedError:self
- ].
-
- "
- 'foo' asFilename writeStream close.
- 'foo' asFilename removeAccessRights:#(readUser readGroup readOthers).
- 'foo' asFilename removeAccessRights:#(writeUser writeGroup writeOthers).
- 'foo' asFilename removeAccessRights:#(executeUser executeGroup executeOthers).
- "
+ ^ self class separator
!
-makeReadableForAll
- "make the file readable for all - you must have permission to do so."
+suffix
+ "return my suffix.
+ The suffix is the namepart after the final period character,
+ or the empty string, if the name does not contain a period."
+
+ ^ self prefixAndSuffix at:2
- ^ self addAccessRights:#(readUser readGroup readOthers)
-!
+ "
+ 'abc.st' asFilename suffix
+ 'abc' asFilename suffix
+ 'a.b.c' asFilename suffix
+ "
-makeReadable
- "make the file readable for the owner - you must have permission to do so."
-
- ^ self addAccessRights:#(readUser)
+ "Modified: 7.9.1995 / 11:09:03 / claus"
!
-makeWritable
- "make the file writableable for all - you must have permission to do so."
-
- ^ self addAccessRights:#(writeUser)
-!
+tail
+ "the files name without directory prefix as a string.
+ An alias for baseName, for ST-80 compatiblity."
-makeWritableForAll
- "make the file writable for all - you must have permission to do so."
-
- ^ self addAccessRights:#(writeUser writeGroup writeOthers)
-!
-
-makeUnwritable
- "make the file unwritable for all - you must have permission to do so."
-
- ^ self removeAccessRights:#(writeUser writeGroup writeOthers)
+ ^ self baseName
! !
-!Filename methodsFor:'file utilities'!
-
-fileIn
- "load smalltalk code from the file"
-
- ^ self readStream fileIn
-!
-
-edit
- "start an editView on the file represented by the receiver"
-
- EditTextView openOn:self asString
-
- "
- 'smalltalk.rc' asFilename edit
- "
-!
-
-contentsOfEntireFile
- "return the contents of the file as a string"
-
- |s contents|
-
- s := self readStream.
- [
- contents := s contents
- ] valueNowOrOnUnwindDo:[s close].
- ^ contents
-! !
-
-!Filename methodsFor:'file access'!
-
-newReadWriteStream
- "return a stream for read/write the file represented by the receiver.
- If the file does not already exist, it is created."
-
- ^ FileStream newFileNamed:nameString
-!
-
-readWriteStream
- "return a stream for read/write the file represented by the receiver.
- If the file does not already exist, nil is returned."
-
- ^ FileStream oldFileNamed:nameString
-!
-
-readStream
- "return a stream for reading from the file represented by the receiver.
- If the file does not already exist, nil is returned."
-
- ^ FileStream readonlyFileNamed:nameString
-
- "
- '/tmp/foo' asFilename readStream
- "
-!
-
-writeStream
- "return a stream for writing to the file represented by the receiver.
- If the file does not already exist, it is created."
-
- ^ FileStream newFileForWritingNamed:nameString
-
- "
- '/tmp/foo' asFilename writeStream
- "
-!
-
-appendingWriteStream
- "return a stream for appending to the file represented by the receiver.
- If the file does not already exist, it is created."
-
- ^ FileStream appendingOldFileNamed:nameString
-! !
-
-!Filename methodsFor:'printing & storing'!
-
-storeOn:aStream
- "append a printed representation of the receiver to aStream,
- which allows reconstructing it via readFrom:"
-
- aStream nextPut:$(.
- nameString storeOn:aStream.
- aStream nextPutAll:' asFilename)'
-!
-
-printOn:aStream
- "append a printed representation of the receiver to aStream."
-
- aStream nextPutAll:'FileName('''.
- nameString printOn:aStream.
- aStream nextPutAll:''')'
-! !
--- a/HRegistry.st Thu Nov 23 02:52:35 1995 +0100
+++ b/HRegistry.st Thu Nov 23 03:01:22 1995 +0100
@@ -11,10 +11,10 @@
"
Registry subclass:#HandleRegistry
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- category:'System-Support'
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Support'
!
!HandleRegistry class methodsFor:'documentation'!
@@ -33,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/HRegistry.st,v 1.4 1995-11-11 15:23:25 cg Exp $'
-!
-
documentation
"
HandleRegistries are like Registries, in that they watch for the death of
@@ -45,6 +41,10 @@
Use Registry for objects which know themself how to clean up;
use HandleRegistry, if someone else does the cleanup.
"
+!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/HRegistry.st,v 1.5 1995-11-23 02:00:59 cg Exp $'
! !
!HandleRegistry methodsFor:'dispose handling'!
@@ -55,14 +55,15 @@
!HandleRegistry methodsFor:'redefined to block'!
-registerChange:anObject
- "not useful for HandleRegistry"
+register:anObject
+ "not useful for HandleRegistry - use #register:as:"
self shouldNotImplement
!
-register:anObject
- "not useful for HandleRegistry - use #register:as:"
+registerChange:anObject
+ "not useful for HandleRegistry"
self shouldNotImplement
! !
+
--- a/HandleRegistry.st Thu Nov 23 02:52:35 1995 +0100
+++ b/HandleRegistry.st Thu Nov 23 03:01:22 1995 +0100
@@ -11,10 +11,10 @@
"
Registry subclass:#HandleRegistry
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- category:'System-Support'
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Support'
!
!HandleRegistry class methodsFor:'documentation'!
@@ -33,10 +33,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/HandleRegistry.st,v 1.4 1995-11-11 15:23:25 cg Exp $'
-!
-
documentation
"
HandleRegistries are like Registries, in that they watch for the death of
@@ -45,6 +41,10 @@
Use Registry for objects which know themself how to clean up;
use HandleRegistry, if someone else does the cleanup.
"
+!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/HandleRegistry.st,v 1.5 1995-11-23 02:00:59 cg Exp $'
! !
!HandleRegistry methodsFor:'dispose handling'!
@@ -55,14 +55,15 @@
!HandleRegistry methodsFor:'redefined to block'!
-registerChange:anObject
- "not useful for HandleRegistry"
+register:anObject
+ "not useful for HandleRegistry - use #register:as:"
self shouldNotImplement
!
-register:anObject
- "not useful for HandleRegistry - use #register:as:"
+registerChange:anObject
+ "not useful for HandleRegistry"
self shouldNotImplement
! !
+
--- a/ObjMem.st Thu Nov 23 02:52:35 1995 +0100
+++ b/ObjMem.st Thu Nov 23 03:01:22 1995 +0100
@@ -11,30 +11,61 @@
"
Object subclass:#ObjectMemory
- instanceVariableNames:''
- classVariableNames:'InternalErrorHandler UserInterruptHandler TimerInterruptHandler
- SpyInterruptHandler StepInterruptHandler ExceptionInterruptHandler
- ErrorInterruptHandler MemoryInterruptHandler SignalInterruptHandler
- ChildSignalInterruptHandler DisposeInterruptHandler
- RecursionInterruptHandler IOInterruptHandler
- CustomInterruptHandler
- RegisteredErrorInterruptHandlers
- InterruptLatencyMonitor
-
- AllocationFailureSignal MallocFailureSignal LowSpaceSemaphore
- IncrementalGCLimit FreeSpaceGCLimit FreeSpaceGCAmount
- BackgroundCollectProcess BackgroundFinalizationProcess
- FinalizationSemaphore
- Dependents
- ImageName ChangeFileName
-
- MaxInterruptLatency InterruptLatencyGoal'
- poolDictionaries:''
- category:'System-Support'
+ instanceVariableNames:''
+ classVariableNames:'InternalErrorHandler UserInterruptHandler TimerInterruptHandler
+ SpyInterruptHandler StepInterruptHandler
+ ExceptionInterruptHandler ErrorInterruptHandler
+ MemoryInterruptHandler SignalInterruptHandler
+ ChildSignalInterruptHandler DisposeInterruptHandler
+ RecursionInterruptHandler IOInterruptHandler
+ CustomInterruptHandler RegisteredErrorInterruptHandlers
+ InterruptLatencyMonitor AllocationFailureSignal
+ MallocFailureSignal LowSpaceSemaphore IncrementalGCLimit
+ FreeSpaceGCLimit FreeSpaceGCAmount BackgroundCollectProcess
+ BackgroundFinalizationProcess FinalizationSemaphore Dependents
+ ImageName ChangeFileName MaxInterruptLatency InterruptLatencyGoal'
+ poolDictionaries:''
+ category:'System-Support'
!
!ObjectMemory class methodsFor:'documentation'!
+caching
+"
+ The system uses various caches to speed up method-lookup.
+ Currently, there is a three-level cache hierarchy:
+
+ inline-cache keeps the target of the last send at the caller-
+ side (i.e. every send goes through its private
+ 1-slot inline-cache, where the address of the last
+ called function at this call location is kept.)
+
+ polymorph-inline-cache keeps a limited list of all targets ever reached
+ at this call location. The list is automatically
+ flushed if it grows too large, or the overall number
+ of poly-chache entries exceeds a limit.
+
+ method-lookup-cache a global cache. Hashes on class-selector pairs,
+ returning the target method.
+
+ Whenever methods are added or removed from the system, or the inheritance
+ hierarchy changes, some or all caches have to be flushed.
+ The flushXXX methods perform the task of flushing various caches.
+ All standard methods in Behavior call for cache flushing, when things change;
+ however, if you use the low level access methods in Behavior
+ (for example: #setSuperclass:) special care has to be taken.
+
+ In some situations, not all caches need flushing, for example a change
+ in an interpreted method (currently) needs no flushing of the inline caches.
+ Also, flushing can be limited to entries for a specific class for most changes.
+
+ To be 'on the brigth side of live', use ObjectMemory>>flushCaches (which
+ flushes all of them), when in doubt of which caches should be flushed.
+ It is better flush too much - otherwise you may end up in a wrong method after
+ a send.
+"
+!
+
copyright
"
COPYRIGHT (c) 1992 by Claus Gittinger
@@ -49,10 +80,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.77 1995-11-13 09:08:12 stefan Exp $'
-!
-
documentation
"
This class contains access methods to the system memory and the VM.
@@ -145,98 +172,6 @@
"
!
-caching
-"
- The system uses various caches to speed up method-lookup.
- Currently, there is a three-level cache hierarchy:
-
- inline-cache keeps the target of the last send at the caller-
- side (i.e. every send goes through its private
- 1-slot inline-cache, where the address of the last
- called function at this call location is kept.)
-
- polymorph-inline-cache keeps a limited list of all targets ever reached
- at this call location. The list is automatically
- flushed if it grows too large, or the overall number
- of poly-chache entries exceeds a limit.
-
- method-lookup-cache a global cache. Hashes on class-selector pairs,
- returning the target method.
-
- Whenever methods are added or removed from the system, or the inheritance
- hierarchy changes, some or all caches have to be flushed.
- The flushXXX methods perform the task of flushing various caches.
- All standard methods in Behavior call for cache flushing, when things change;
- however, if you use the low level access methods in Behavior
- (for example: #setSuperclass:) special care has to be taken.
-
- In some situations, not all caches need flushing, for example a change
- in an interpreted method (currently) needs no flushing of the inline caches.
- Also, flushing can be limited to entries for a specific class for most changes.
-
- To be 'on the brigth side of live', use ObjectMemory>>flushCaches (which
- flushes all of them), when in doubt of which caches should be flushed.
- It is better flush too much - otherwise you may end up in a wrong method after
- a send.
-"
-!
-
-interrupts
-"
- Handling of interrupts (i.e. unix-signals) is done via handler objects, which
- get a #XXXInterrupt-message sent. This is more flexible than (say) signalling
- a semaphore, since the handler-object may do anything to react on the signal
- (of course, it can also signal a semaphore to emulate the above behavior).
-
- Another reason for having handler objects is that they allow interrupt handling
- without any context switch, for high speed interrupt response.
- However, if you do this, special care is needed, since it is not defined,
- which process gets the interrupt and will do the processing (therefore,
- the default setup installs handlers which simply signal a semaphore and
- continue the running process).
-
- Typically, the handlers are set during early initialization of the system
- by sending 'ObjectMemory XXXInterruptHandler:aHandler' and not changed later.
- (see Smalltalk>>initialize or ProcessorScheduler>>initialize).
- To setup your own handler, create some object which responds to #xxxInterrupt,
- and make it the handler using the above method.
-
- Interrupt messages sent to handlers are:
- internalError:<someString> - internal interpreter/GC errors
- userInterrupt - ^C interrupt
- customInterrupt - custom interrupt
- ioInterrupt - SIGIO interrupt
- timerInterrupt - alarm timer (SIGALRM)
- errorInterrupt:<id> - errors from other primitives/subsystems
- (DisplayError)
- spyInterrupt - spy timer interrupt (SIGVTALARM)
- stepInterrupt - single step interrupt
- disposeInterrupt - finalization required
- recursionInterrupt - recursion (stack) overflow
- memoryInterrupt - soon running out of memory
- fpExceptionInterrupt - floating point exception (SIGFPE)
- childSignalInterrupt - death of a child process (SIGCHILD)
- signalInterrupt:<number> - unix signal (if other than above signals)
-
- To avoid frustration in case of badly set handlers, these messages
- are also implemented in the Object class - thus anything can be defined
- as interrupt handler. However, the VM will not send any
- interrupt message, if the corresonding handler object is nil
- (which means that nil is a bad choice, if you are interrested in the event).
-
- Interrupt processing is not immediately after the event arrives: there
- are certain ``save-places'' at which this handling is performed
- (message send, method return and loop-heads).
- If not explicitely enabled, primitive code is never interrupted.
-
- Interrupts may be disabled (OperatingSystem blockInterrupts) and reenabled
- (unblockInterrupts) to allow for critical data to be manipulated.
- Every process has its own interrupt-enable state which is switched
- when processes switch control (i.e. you cannot block interrupts across
- a suspend, delay etc.). However, the state will be restored after a resume.
-"
-!
-
garbageCollection
"
Currently, Smalltalk/X uses a two-level memory hierachy (actually, there
@@ -567,6 +502,66 @@
special features you are using - this provides the feedback required to decide
which methods are to be removed, kept or enhanced in future versions.
"
+!
+
+interrupts
+"
+ Handling of interrupts (i.e. unix-signals) is done via handler objects, which
+ get a #XXXInterrupt-message sent. This is more flexible than (say) signalling
+ a semaphore, since the handler-object may do anything to react on the signal
+ (of course, it can also signal a semaphore to emulate the above behavior).
+
+ Another reason for having handler objects is that they allow interrupt handling
+ without any context switch, for high speed interrupt response.
+ However, if you do this, special care is needed, since it is not defined,
+ which process gets the interrupt and will do the processing (therefore,
+ the default setup installs handlers which simply signal a semaphore and
+ continue the running process).
+
+ Typically, the handlers are set during early initialization of the system
+ by sending 'ObjectMemory XXXInterruptHandler:aHandler' and not changed later.
+ (see Smalltalk>>initialize or ProcessorScheduler>>initialize).
+ To setup your own handler, create some object which responds to #xxxInterrupt,
+ and make it the handler using the above method.
+
+ Interrupt messages sent to handlers are:
+ internalError:<someString> - internal interpreter/GC errors
+ userInterrupt - ^C interrupt
+ customInterrupt - custom interrupt
+ ioInterrupt - SIGIO interrupt
+ timerInterrupt - alarm timer (SIGALRM)
+ errorInterrupt:<id> - errors from other primitives/subsystems
+ (DisplayError)
+ spyInterrupt - spy timer interrupt (SIGVTALARM)
+ stepInterrupt - single step interrupt
+ disposeInterrupt - finalization required
+ recursionInterrupt - recursion (stack) overflow
+ memoryInterrupt - soon running out of memory
+ fpExceptionInterrupt - floating point exception (SIGFPE)
+ childSignalInterrupt - death of a child process (SIGCHILD)
+ signalInterrupt:<number> - unix signal (if other than above signals)
+
+ To avoid frustration in case of badly set handlers, these messages
+ are also implemented in the Object class - thus anything can be defined
+ as interrupt handler. However, the VM will not send any
+ interrupt message, if the corresonding handler object is nil
+ (which means that nil is a bad choice, if you are interrested in the event).
+
+ Interrupt processing is not immediately after the event arrives: there
+ are certain ``save-places'' at which this handling is performed
+ (message send, method return and loop-heads).
+ If not explicitely enabled, primitive code is never interrupted.
+
+ Interrupts may be disabled (OperatingSystem blockInterrupts) and reenabled
+ (unblockInterrupts) to allow for critical data to be manipulated.
+ Every process has its own interrupt-enable state which is switched
+ when processes switch control (i.e. you cannot block interrupts across
+ a suspend, delay etc.). However, the state will be restored after a resume.
+"
+!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.78 1995-11-23 02:01:22 cg Exp $'
! !
!ObjectMemory class methodsFor:'initialization'!
@@ -591,6 +586,67 @@
MemoryInterruptHandler := self
! !
+!ObjectMemory class methodsFor:'ST-80 compatibility'!
+
+availableFreeBytes
+ ^ self freeSpace + self freeListSpace
+
+ "
+ ObjectMemory availableFreeBytes
+ "
+!
+
+bytesPerOOP
+ "return the number of bytes an object reference (for example: an instvar)
+ takes"
+
+%{ /* NOCONTEXT */
+ RETURN(__MKSMALLINT(sizeof(OBJ)));
+%}
+
+ "
+ ObjectMemory bytesPerOOP
+ "
+!
+
+bytesPerOTE
+ "return the number of overhead bytes of an object.
+ i.e. the number of bytes in every objects header."
+
+%{ /* NOCONTEXT */
+ RETURN(__MKSMALLINT(OHDR_SIZE));
+%}
+
+ "
+ ObjectMemory bytesPerOTE
+ "
+!
+
+compactingGC
+ self garbageCollect
+!
+
+current
+ ^ self
+!
+
+globalCompactingGC
+ self garbageCollect
+!
+
+growMemoryBy:numberOfBytes
+ ^ self moreOldSpace:numberOfBytes
+!
+
+numOopsNumBytes
+ ^ Array with:(self numberOfObjects)
+ with:(self bytesUsed)
+
+ "
+ ObjectMemory numOopsNumBytes
+ "
+! !
+
!ObjectMemory class methodsFor:'Signal constants'!
allocationFailureSignal
@@ -607,41 +663,16 @@
^ MallocFailureSignal
! !
-!ObjectMemory class methodsFor:'semaphore access'!
-
-lowSpaceSemaphore
- "return the semaphore that is signalled when the system detects a
- low space condition. Usually, some time after this, an allocationFailure
- will happen. You can have a cleanup process sitting in that semaphore and
- start to release object."
-
- ^ LowSpaceSemaphore
-! !
-
!ObjectMemory class methodsFor:'VM messages'!
-infoPrinting:aBoolean
- "turn on/off various informational printouts in the VM.
- For example, the GC activity messages are controlled by
- this flags setting.
- The default is true, since (currently) those messages
- are useful for ST/X developers."
-
-%{ /* NOCONTEXT */
- extern int __infoPrinting;
-
- __infoPrinting = (aBoolean == true);
-%}
-!
-
-infoPrinting
- "return true, if various informational printouts in the VM
+debugPrinting
+ "return true, if various debug printouts in the VM
are turned on, false of off."
%{ /* NOCONTEXT */
- extern int __infoPrinting;
-
- RETURN (__infoPrinting ? true : false);
+ extern int __debugPrinting;
+
+ RETURN (__debugPrinting ? true : false);
%}
!
@@ -660,14 +691,324 @@
%}
!
-debugPrinting
- "return true, if various debug printouts in the VM
+infoPrinting
+ "return true, if various informational printouts in the VM
are turned on, false of off."
%{ /* NOCONTEXT */
- extern int __debugPrinting;
-
- RETURN (__debugPrinting ? true : false);
+ extern int __infoPrinting;
+
+ RETURN (__infoPrinting ? true : false);
+%}
+!
+
+infoPrinting:aBoolean
+ "turn on/off various informational printouts in the VM.
+ For example, the GC activity messages are controlled by
+ this flags setting.
+ The default is true, since (currently) those messages
+ are useful for ST/X developers."
+
+%{ /* NOCONTEXT */
+ extern int __infoPrinting;
+
+ __infoPrinting = (aBoolean == true);
+%}
+! !
+
+!ObjectMemory class methodsFor:'cache management'!
+
+flushCaches
+ "flush method and inline caches for all classes"
+
+%{ /* NOCONTEXT */
+ __flushMethodCache();
+ __flushAllInlineCaches();
+%}
+!
+
+flushCachesFor:aClass
+ "flush method and inline caches for aClass"
+
+%{ /* NOCONTEXT */
+ __flushMethodCacheFor(aClass);
+ __flushInlineCachesFor(aClass);
+%}
+!
+
+flushCachesForSelector:aSelector
+ "flush method and inline caches for aSelector"
+
+%{ /* NOCONTEXT */
+ __flushMethodCacheForSelector(aSelector);
+ __flushInlineCachesForSelector(aSelector);
+%}
+!
+
+flushInlineCaches
+ "flush all inlinecaches"
+
+%{ /* NOCONTEXT */
+ __flushAllInlineCaches();
+%}
+!
+
+flushInlineCachesFor:aClass withArgs:nargs
+ "flush inlinecaches for calls to aClass with nargs arguments"
+
+%{ /* NOCONTEXT */
+ __flushInlineCachesForAndNargs(aClass, _intVal(nargs));
+%}
+!
+
+flushInlineCachesForClass:aClass
+ "flush inlinecaches for calls to aClass."
+
+%{ /* NOCONTEXT */
+ __flushInlineCachesFor(aClass);
+%}
+!
+
+flushInlineCachesForSelector:aSelector
+ "flush inlinecaches for sends of aSelector"
+
+%{ /* NOCONTEXT */
+ __flushInlineCachesForSelector(aSelector);
+%}
+!
+
+flushInlineCachesWithArgs:nargs
+ "flush inlinecaches for calls with nargs arguments"
+
+%{ /* NOCONTEXT */
+ __flushInlineCaches(_intVal(nargs));
+%}
+!
+
+flushMethodCache
+ "flush the method cache"
+
+%{ /* NOCONTEXT */
+ __flushMethodCache();
+%}
+!
+
+flushMethodCacheFor:aClass
+ "flush the method cache for sends to aClass"
+
+%{ /* NOCONTEXT */
+ __flushMethodCacheFor(aClass);
+%}
+!
+
+flushMethodCacheForSelector:aSelector
+ "flush the method cache for sends of aSelector"
+
+%{ /* NOCONTEXT */
+ __flushMethodCacheForSelector(aSelector);
+%}
+!
+
+trapRestrictedMethods:trap
+ "Allow/Deny execution of restricted Methods (see Method>>>restricted:)
+
+ Notice: method restriction is a nonstandard feature, not supported
+ by other smalltalk implementations and not specified in the ANSI spec.
+ This is EXPERIMENTAL - and being evaluated for usability.
+ It may change or even vanish (if it shows to be not useful)."
+
+ |oldTrap|
+
+%{
+ if (__setTrapRestrictedMethods(trap == true))
+ oldTrap = true;
+ else
+ oldTrap = false;
+%}.
+
+ (trap and:[oldTrap not]) ifTrue:[
+ self flushCaches
+ ].
+ ^ oldTrap
+
+ "
+ ObjectMemory trapRestrictedMethods:true
+ ObjectMemory trapRestrictedMethods:false
+ "
+! !
+
+!ObjectMemory class methodsFor:'debug queries'!
+
+addressOf:anObject
+ "return the core address of anObject as an integer
+ - since objects may move around, the returned value is invalid after the
+ next scavenge/collect.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{ /* NOCONTEXT */
+
+ if (! __isNonNilObject(anObject)) {
+ RETURN ( nil );
+ }
+ if (((int)anObject >= _MIN_INT) && ((int)anObject <= _MAX_INT)) {
+ RETURN ( _MKSMALLINT((int)anObject) );
+ }
+ RETURN ( _MKLARGEINT((int)anObject) );
+%}
+ "
+ |p|
+ p := Point new.
+ ((ObjectMemory addressOf:p) printStringRadix:16) printNL.
+ ObjectMemory scavenge.
+ ((ObjectMemory addressOf:p) printStringRadix:16) printNL.
+ "
+!
+
+ageOf:anObject
+ "return the number of scavenges, an object has survived
+ in new space.
+ For old objects and living contexts, the returned number is invalid.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{ /* NOCONTEXT */
+
+ if (! __isNonNilObject(anObject)) {
+ RETURN ( 0 );
+ }
+ RETURN ( _MKSMALLINT( _GET_AGE(anObject) ) );
+%}
+ "
+ |p|
+ p := Point new.
+ (ObjectMemory ageOf:p) printNL.
+ ObjectMemory tenuringScavenge.
+ (ObjectMemory spaceOf:p) printNL.
+ ObjectMemory tenuringScavenge.
+ (ObjectMemory spaceOf:p) printNL.
+ ObjectMemory tenuringScavenge.
+ (ObjectMemory spaceOf:p) printNL.
+ ObjectMemory tenuringScavenge.
+ (ObjectMemory spaceOf:p) printNL.
+ "
+!
+
+dumpObject:someObject
+ "low level dump an object.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{
+ dumpObject(someObject);
+%}
+ "
+ ObjectMemory dumpObject:true
+ ObjectMemory dumpObject:(Array new:10)
+ ObjectMemory dumpObject:(10@20 corner:30@40)
+ "
+!
+
+flagsOf:anObject
+ "For debugging only.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{ /* NOCONTEXT */
+
+ if (! __isNonNilObject(anObject)) {
+ RETURN ( nil );
+ }
+ RETURN ( _MKSMALLINT( anObject->o_flags ) );
+%}
+ "
+F_ISREMEMBERED 1 /* a new-space thing being refd by some oldSpace thing */
+F_ISFORWARDED 2 /* a forwarded object (you will never see this here) */
+F_DEREFERENCED 4 /* a collection after grow (not currently used) */
+F_ISONLIFOLIST 8 /* a non-lifo-context-referencing-obj already on list */
+F_MARK 16 /* mark bit for background collector */
+ "
+
+ "
+ |arr|
+
+ arr := Array new.
+ arr at:1 put:([thisContext] value).
+ (ObjectMemory flagsOf:anObject) printNL
+ "
+!
+
+objectAt:anAddress
+ "return whatever anAddress points to as object.
+ BIG BIG DANGER ALERT:
+ this method is only to be used for debugging ST/X itself
+ - you can easily (and badly) crash the system.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+ |low high|
+
+ low := anAddress bitAnd:16rFFFF.
+ high := (anAddress bitShift:16) bitAnd:16rFFFF.
+%{
+ if (__bothSmallInteger(low, high)) {
+ RETURN ((OBJ)((_intVal(high) << 16) | _intVal(low)));
+ }
+%}
+!
+
+printReferences:anObject
+ "for debugging: print referents to anObject.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice
+ use ObjectMemory>>whoReferences: or anObject>>allOwners."
+
+%{
+ __printRefChain(__context, anObject);
+%}
+!
+
+sizeOf:anObject
+ "return the size of anObject in bytes.
+ (this is not the same as 'anObject size').
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{ /* NOCONTEXT */
+
+ RETURN ( __isNonNilObject(anObject) ? _MKSMALLINT(__qSize(anObject)) : _MKSMALLINT(0) )
+%}
+ "
+ |hist big nw|
+
+ hist := Array new:100 withAll:0.
+ big := 0.
+ ObjectMemory allObjectsDo:[:o |
+ nw := (ObjectMemory sizeOf:o) // 4 + 1.
+ nw > 100 ifTrue:[
+ big := big + 1
+ ] ifFalse:[
+ hist at:nw put:(hist at:nw) + 1
+ ].
+ ].
+ hist printNL.
+ big printNL
+ "
+!
+
+spaceOf:anObject
+ "return the memory space, in which anObject is.
+ - since objects may move between spaces,
+ the returned value may be invalid after the next scavenge/collect.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{ /* NOCONTEXT */
+
+ if (! __isNonNilObject(anObject)) {
+ RETURN ( nil );
+ }
+ RETURN ( _MKSMALLINT( __qSpace(anObject) ) );
%}
! !
@@ -706,150 +1047,8 @@
]
! !
-!ObjectMemory class methodsFor:'cache management'!
-
-flushInlineCachesForClass:aClass
- "flush inlinecaches for calls to aClass."
-
-%{ /* NOCONTEXT */
- __flushInlineCachesFor(aClass);
-%}
-!
-
-flushInlineCachesWithArgs:nargs
- "flush inlinecaches for calls with nargs arguments"
-
-%{ /* NOCONTEXT */
- __flushInlineCaches(_intVal(nargs));
-%}
-!
-
-flushInlineCachesFor:aClass withArgs:nargs
- "flush inlinecaches for calls to aClass with nargs arguments"
-
-%{ /* NOCONTEXT */
- __flushInlineCachesForAndNargs(aClass, _intVal(nargs));
-%}
-!
-
-flushInlineCachesForSelector:aSelector
- "flush inlinecaches for sends of aSelector"
-
-%{ /* NOCONTEXT */
- __flushInlineCachesForSelector(aSelector);
-%}
-!
-
-flushInlineCaches
- "flush all inlinecaches"
-
-%{ /* NOCONTEXT */
- __flushAllInlineCaches();
-%}
-!
-
-flushMethodCacheFor:aClass
- "flush the method cache for sends to aClass"
-
-%{ /* NOCONTEXT */
- __flushMethodCacheFor(aClass);
-%}
-!
-
-flushMethodCacheForSelector:aSelector
- "flush the method cache for sends of aSelector"
-
-%{ /* NOCONTEXT */
- __flushMethodCacheForSelector(aSelector);
-%}
-!
-
-flushMethodCache
- "flush the method cache"
-
-%{ /* NOCONTEXT */
- __flushMethodCache();
-%}
-!
-
-flushCachesFor:aClass
- "flush method and inline caches for aClass"
-
-%{ /* NOCONTEXT */
- __flushMethodCacheFor(aClass);
- __flushInlineCachesFor(aClass);
-%}
-!
-
-flushCachesForSelector:aSelector
- "flush method and inline caches for aSelector"
-
-%{ /* NOCONTEXT */
- __flushMethodCacheForSelector(aSelector);
- __flushInlineCachesForSelector(aSelector);
-%}
-!
-
-flushCaches
- "flush method and inline caches for all classes"
-
-%{ /* NOCONTEXT */
- __flushMethodCache();
- __flushAllInlineCaches();
-%}
-!
-
-trapRestrictedMethods:trap
- "Allow/Deny execution of restricted Methods (see Method>>>restricted:)
-
- Notice: method restriction is a nonstandard feature, not supported
- by other smalltalk implementations and not specified in the ANSI spec.
- This is EXPERIMENTAL - and being evaluated for usability.
- It may change or even vanish (if it shows to be not useful)."
-
- |oldTrap|
-
-%{
- if (__setTrapRestrictedMethods(trap == true))
- oldTrap = true;
- else
- oldTrap = false;
-%}.
-
- (trap and:[oldTrap not]) ifTrue:[
- self flushCaches
- ].
- ^ oldTrap
-
- "
- ObjectMemory trapRestrictedMethods:true
- ObjectMemory trapRestrictedMethods:false
- "
-! !
-
!ObjectMemory class methodsFor:'enumerating'!
-allObjectsDo:aBlock
- "evaluate the argument, aBlock for all objects in the system.
- There is one caveat: if a compressing oldSpace collect
- occurs while looping over the objects, the loop cannot be
- continued (for some internal reasons). In this case, false
- is returned."
-
- |work|
-
-%{ /* NOREGISTER - work may not be placed into a register here */
- __nonTenuringScavenge(__context);
- /*
- * allObjectsDo needs a temporary to hold newSpace objects
- */
- if (__allInstancesOfDo((OBJ *)0, &aBlock, &work COMMA_CON) < 0) {
- RETURN (false);
- }
-%}.
- ^ true
-!
-
allInstancesOf:aClass do:aBlock
"evaluate the argument, aBlock for all instances of aClass in the system.
There is one caveat: if a compressing oldSpace collect
@@ -871,6 +1070,27 @@
^ true
!
+allObjectsDo:aBlock
+ "evaluate the argument, aBlock for all objects in the system.
+ There is one caveat: if a compressing oldSpace collect
+ occurs while looping over the objects, the loop cannot be
+ continued (for some internal reasons). In this case, false
+ is returned."
+
+ |work|
+
+%{ /* NOREGISTER - work may not be placed into a register here */
+ __nonTenuringScavenge(__context);
+ /*
+ * allObjectsDo needs a temporary to hold newSpace objects
+ */
+ if (__allInstancesOfDo((OBJ *)0, &aBlock, &work COMMA_CON) < 0) {
+ RETURN (false);
+ }
+%}.
+ ^ true
+!
+
allOldObjectsDo:aBlock
"evaluate the argument, aBlock for all old objects in the system.
For debugging and tests only - do not use"
@@ -882,962 +1102,15 @@
^ true
! !
-!ObjectMemory class methodsFor:'interrupt handler access'!
-
-internalErrorHandler
- "return the handler for ST/X internal errors.
- An internal error is reported for example when a methods
- bytecode is not a ByteArray, the selector table is not an Array
- etc.
- Those should not occur in normal circumstances."
-
- ^ InternalErrorHandler
-!
-
-userInterruptHandler
- "return the handler for CNTL-C interrupt handling"
-
- ^ UserInterruptHandler
-!
-
-userInterruptHandler:aHandler
- "set the handler for CNTL-C interrupt handling"
-
- UserInterruptHandler := aHandler
-!
-
-timerInterruptHandler
- "return the handler for timer interrupts"
-
- ^ TimerInterruptHandler
-!
-
-timerInterruptHandler:aHandler
- "set the handler for timer interrupts"
-
- TimerInterruptHandler := aHandler
-!
-
-spyInterruptHandler
- "return the handler for spy-timer interrupts"
-
- ^ SpyInterruptHandler
-!
-
-spyInterruptHandler:aHandler
- "set the handler for spy-timer interrupts"
-
- SpyInterruptHandler := aHandler
-!
-
-stepInterruptHandler
- "return the handler for single step interrupts"
-
- ^ StepInterruptHandler
-!
-
-stepInterruptHandler:aHandler
- "set the handler for single step interrupts"
-
- StepInterruptHandler := aHandler
-!
-
-exceptionInterruptHandler
- "return the handler for floating point exception interrupts"
-
- ^ ExceptionInterruptHandler
-!
-
-errorInterruptHandler
- "return the handler for display error interrupts"
-
- ^ ErrorInterruptHandler
-!
-
-errorInterruptHandler:aHandler
- "set the handler for display error interrupts"
-
- ErrorInterruptHandler := aHandler
-!
-
-registeredErrorInterruptHandlers
- "return registered handlers"
-
- ^ RegisteredErrorInterruptHandlers
-!
-
-registerErrorInterruptHandler:aHandler forID:errorIDSymbol
- "register a handler"
-
- RegisteredErrorInterruptHandlers isNil ifTrue:[
- RegisteredErrorInterruptHandlers := IdentityDictionary new
- ].
- RegisteredErrorInterruptHandlers at:errorIDSymbol put:aHandler
-!
-
-signalInterruptHandler
- "return the handler for UNIX-signal interrupts"
-
- ^ SignalInterruptHandler
-!
-
-signalInterruptHandler:aHandler
- "set the handler for UNIX-signal interrupts"
-
- SignalInterruptHandler := aHandler
-!
-
-childSignalInterruptHandler
- "return the handler for UNIX-death-of-a-childprocess-signal interrupts"
-
- ^ ChildSignalInterruptHandler
-!
-
-disposeInterruptHandler
- "return the handler for object disposal interrupts"
-
- ^ DisposeInterruptHandler
-!
-
-disposeInterruptHandler:aHandler
- "set the handler for object disposal interrupts"
-
- DisposeInterruptHandler := aHandler
-!
-
-recursionInterruptHandler
- "return the handler for recursion/stack overflow interrupts"
-
- ^ RecursionInterruptHandler
-!
-
-recursionInterruptHandler:aHandler
- "set the handler for recursion/stack overflow interrupts"
-
- RecursionInterruptHandler := aHandler
-!
-
-ioInterruptHandler
- "return the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
-
- ^ IOInterruptHandler
-!
-
-ioInterruptHandler:aHandler
- "set the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
-
- IOInterruptHandler := aHandler
-!
-
-customInterruptHandler
- "return the handler for custom interrupts"
-
- ^ CustomInterruptHandler
-!
-
-customInterruptHandler:aHandler
- "set the handler for custom interrupts"
-
- CustomInterruptHandler := aHandler
-! !
-
-!ObjectMemory class methodsFor:'interrupt statistics'!
-
-interruptLatencyMonitor
- "return the interrupt-latency-monitor if any.
- See comment in #interruptLatencyMonitor:.
- This is a non-standard debugging/realtime instrumentation entry."
-
- ^ InterruptLatencyMonitor
-!
-
-interruptLatencyMonitor:aHandler
- "set the interrupt latency monitor. If non-nil, this one will be sent
- an interruptLatency: message with the millisecond delay between
- the interrupt and its handling.
- This is a non-standard debugging/realtime instrumentation entry."
-
- InterruptLatencyMonitor := aHandler
-!
-
-interruptLatency:ms receiver:rec class:cls selector:sel vmActivity:vmActivity
- "example implementation of latencyTime monitoring:
- This method simply measures the max-latency time.
- You may want to use some other handler (see #interruptLatencyMonitor:)
- and extract more information (blocking context).
- DEMO Example."
-
- ms > MaxInterruptLatency ifTrue:[
- MaxInterruptLatency := ms.
- 'IRQ-LATENCY: ' infoPrint. rec class infoPrint. ' ' infoPrint. sel infoPrint. '(' infoPrint. vmActivity infoPrint . ') ---> ' infoPrint. ms infoPrintNL.
- ].
- (InterruptLatencyGoal notNil and:[ms > InterruptLatencyGoal]) ifTrue:[
- '*** IRQ REALTIME-DEADLINE MISSED: ' errorPrint.
- rec isBehavior ifTrue:[
- rec name errorPrint. 'class' errorPrint.
- ] ifFalse:[
- rec class errorPrint
- ].
- ' ' errorPrint. sel errorPrint. '(' errorPrint. vmActivity errorPrint . ') ---> ' errorPrint.
- ms errorPrintNL.
- ].
-
- "to enable the demo handler:
-
- ObjectMemory resetMaxInterruptLatency.
- ObjectMemory interruptLatencyMonitor:ObjectMemory.
- "
- "to disable timing statistics:
-
- ObjectMemory interruptLatencyMonitor:nil.
- ObjectMemory maxInterruptLatency printNL.
- "
-
- "Created: 7.11.1995 / 21:05:50 / cg"
- "Modified: 7.11.1995 / 21:13:33 / cg"
-!
-
-resetMaxInterruptLatency
- "reset the maximum accumulated interrupt latency probe time.
- DEMO Example."
-
- MaxInterruptLatency := 0
-!
-
-interruptLatencyGoal:millis
- "setup to report an error message, whenever a realtime goal could not be
- met due to blocked interrupts or long primitives or GC activity.
- An argument of nil clears the check.
- DEMO Example."
-
- InterruptLatencyGoal := millis.
- millis isNil ifTrue:[
- InterruptLatencyMonitor := nil.
- ] ifFalse:[
- MaxInterruptLatency := 0.
- InterruptLatencyMonitor := self.
- ]
+!ObjectMemory class methodsFor:'garbage collection'!
+
+backgroundCollectorRunning
+ "return true, if a backgroundCollector is running"
+
+ ^ BackgroundCollectProcess notNil
"
- ObjectMemory interruptLatencyGoal:50
- "
-!
-
-maxInterruptLatency
- "return the maximum accumulated interrupt latency in millis.
- DEMO Example."
-
- ^ MaxInterruptLatency
-! !
-
-!ObjectMemory class methodsFor:'queries'!
-
-newSpaceSize
- "return the total size of the new space - this is usually fix"
-
-%{ /* NOCONTEXT */
- extern unsigned __newSpaceSize();
-
- RETURN ( _MKSMALLINT(__newSpaceSize()) );
-%}
- "
- ObjectMemory newSpaceSize
- "
-!
-
-oldSpaceSize
- "return the total size of the old space. - may grow slowly"
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceSize();
-
- RETURN ( _MKSMALLINT(__oldSpaceSize()) );
-%}
- "
- ObjectMemory oldSpaceSize
- "
-!
-
-symSpaceSize
- "return the total size of the sym space."
-
-%{ /* NOCONTEXT */
- extern unsigned __symSpaceSize();
-
- RETURN ( _MKSMALLINT(__symSpaceSize()) );
-%}
- "
- ObjectMemory symSpaceSize
- "
-!
-
-fixSpaceSize
- "return the total size of the fix space."
-
-%{ /* NOCONTEXT */
- extern unsigned __fixSpaceSize();
-
- RETURN ( _MKSMALLINT(__fixSpaceSize()) );
-%}
- "
- ObjectMemory fixSpaceSize
- "
-!
-
-newSpaceUsed
- "return the number of bytes allocated for new objects.
- The returned value is usually obsolete as soon as you do
- something with it ..."
-
-%{ /* NOCONTEXT */
- extern unsigned __newSpaceUsed();
-
- RETURN ( _MKSMALLINT(__newSpaceUsed()) );
-%}
- "
- ObjectMemory newSpaceUsed
- "
-!
-
-oldSpaceUsed
- "return the number of bytes allocated for old objects.
- (This includes the free lists)"
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceUsed();
-
- RETURN ( _MKSMALLINT(__oldSpaceUsed()) );
-%}
- "
- ObjectMemory oldSpaceUsed
- "
-!
-
-symSpaceUsed
- "return the number of bytes allocated for old objects in sym space."
-
-%{ /* NOCONTEXT */
- extern unsigned __symSpaceUsed();
-
- RETURN ( _MKSMALLINT(__symSpaceUsed()) );
-%}
- "
- ObjectMemory symSpaceUsed
- "
-!
-
-fixSpaceUsed
- "return the number of bytes allocated for old objects in fix space."
-
-%{ /* NOCONTEXT */
- extern unsigned __fixSpaceUsed();
-
- RETURN ( _MKSMALLINT(__fixSpaceUsed()) );
-%}
- "
- ObjectMemory fixSpaceUsed
- "
-!
-
-freeSpace
- "return the number of bytes in the compact free area.
- (oldSpaceUsed + freeSpaceSize = oldSpaceSize)"
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceSize(), __oldSpaceUsed();
-
- RETURN ( _MKSMALLINT(__oldSpaceSize() - __oldSpaceUsed()) );
-%}
- "
- ObjectMemory freeSpace
- "
-!
-
-freeListSpace
- "return the number of bytes in the free lists.
- (which is included in oldSpaceUsed)"
-
-%{ /* NOCONTEXT */
- extern unsigned __freeListSpace();
-
- RETURN ( _MKSMALLINT(__freeListSpace()) );
-%}
- "
- ObjectMemory freeListSpace
- "
-!
-
-bytesUsed
- "return the number of bytes allocated for objects -
- this number is not exact, since some objects may already be dead
- (i.e. not yet reclaimed by the garbage collector).
- If you need the exact number, you have to loop over all
- objects and ask for the bytesize using ObjectMemory>>sizeOf:."
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceUsed(), __newSpaceUsed(), __freeListSpace();
-
- RETURN ( _MKSMALLINT(__oldSpaceUsed() + __newSpaceUsed() - __freeListSpace()) );
-%}
- "
- ObjectMemory bytesUsed
- "
-!
-
-oldSpaceAllocatedSinceLastGC
- "return the number of bytes allocated for old objects since the
- last oldspace garbage collect occured. This information is used
- by ProcessorScheduler to decide when to start the incremental
- background GC."
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceAllocatedSinceLastGC();
-
- RETURN ( _MKSMALLINT(__oldSpaceAllocatedSinceLastGC()) );
-%}
- "
- ObjectMemory oldSpaceAllocatedSinceLastGC
- "
-!
-
-tenureAge
- "return the current tenure age - thats the number of times
- an object has to survive scavenges to be moved into oldSpace.
- For statistic/debugging only - this method may vanish"
-
-%{ /* NOCONTEXT */
- extern unsigned __tenureAge();
-
- RETURN ( _MKSMALLINT(__tenureAge()) );
-%}
-!
-
-lastScavengeReclamation
- "returns the number of bytes replacimed by the last scavenge.
- For statistic only - this may vanish."
-
-%{ /* NOCONTEXT */
- extern int __newSpaceReclaimed();
-
- RETURN ( _MKSMALLINT(__newSpaceReclaimed()) );
-%}
- "percentage of reclaimed objects is returned by:
-
- ((ObjectMemory lastScavengeReclamation)
- / (ObjectMemory newSpaceSize)) * 100.0
- "
-!
-
-resetMinScavengeReclamation
- "resets the number of bytes replacimed by the least effective scavenge.
- For statistic only - this may vanish."
-
-%{ /* NOCONTEXT */
- extern int __resetNewSpaceReclaimedMin();
-
- __resetNewSpaceReclaimedMin();
-%}.
- ^ self
- "
- ObjectMemory resetMinScavengeReclamation.
- ObjectMemory minScavengeReclamation
- "
-!
-
-minScavengeReclamation
- "returns the number of bytes replacimed by the least effective scavenge.
- For statistic only - this may vanish."
-
-%{ /* NOCONTEXT */
- extern int __newSpaceReclaimedMin();
-
- RETURN ( _MKSMALLINT(__newSpaceReclaimedMin()) );
-%}
- "
- ObjectMemory minScavengeReclamation
- "
-!
-
-runsSingleOldSpace
- "return true, if the system runs in a single oldSpace or
- false if not.
- The memory system will always drop the second semispace when
- running out of virtual memory, or the baker-limit is reached.
- OBSOLETE:
- the system may now decide at any time to switch between
- single and double-space algorithms, depending on the overall memory
- size. You will now almost always get false as result, since the
- second semispace is only allocated when needed, and released
- immediately afterwards.
- "
-
-%{ /* NOCONTEXT */
- extern int __runsSingleOldSpace();
-
- RETURN ( (__runsSingleOldSpace() ? true : false) );
-%}
- "
- ObjectMemory runsSingleOldSpace
- "
-!
-
-incrementalGCPhase
- "returns the internal state of the incremental GC.
- The meaning of those numbers is a secret :-).
- (for the curious: (currently)
- 2 is idle, 3..11 are various mark phases,
- 12 is the sweep phase. 0 and 1 are cleanup phases when the
- incr. GC gets interrupted by a full GC).
- Do not depend on the values - there may be additional phases in
- future versions (incremental compact ;-).
- This is for debugging and monitoring only - and may change or vanish"
-
-%{ /* NOCONTEXT */
- extern int __incrGCphase();
-
- RETURN (_MKSMALLINT(__incrGCphase()));
-%}
-!
-
-scavengeCount
- "return the number of scavenges that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __scavengeCount();
-
- RETURN (_MKSMALLINT(__scavengeCount()));
-%}
- "
- ObjectMemory scavengeCount
- "
-!
-
-markAndSweepCount
- "return the number of mark&sweep collects that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __markAndSweepCount();
-
- RETURN (_MKSMALLINT(__markAndSweepCount()));
-%}
- "
- ObjectMemory markAndSweepCount
- "
-!
-
-garbageCollectCount
- "return the number of compressing collects that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __garbageCollectCount();
-
- RETURN (_MKSMALLINT(__garbageCollectCount()));
-%}
- "
- ObjectMemory garbageCollectCount
- "
-!
-
-incrementalGCCount
- "return the number of incremental collects that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __incrementalGCCount();
-
- RETURN (_MKSMALLINT(__incrementalGCCount()));
-%}
- "
- ObjectMemory incrementalGCCount
- "
-!
-
-rememberedSetSize
- "return the number of old objects referencing new ones.
- This is a VM debugging interface and may vanish without notice."
-
-%{ /* NOCONTEXT */
- extern int __rememberedSetSize();
-
- RETURN (_MKSMALLINT(__rememberedSetSize()));
-%}
- "
- ObjectMemory rememberedSetSize
- "
-!
-
-lifoRememberedSetSize
- "return the size of the lifoRemSet.
- This is a VM debugging interface and may vanish without notice."
-
-%{ /* NOCONTEXT */
- extern int __lifoRememberedSetSize();
-
- RETURN (_MKSMALLINT(__lifoRememberedSetSize()));
-%}
- "
- ObjectMemory lifoRememberedSetSize
- "
-!
-
-lifoRememberedSet
- "return the lifoRemSet.
- This is pure VM debugging and will vanish without notice."
-
-%{ /* NOCONTEXT */
- extern OBJ __lifoRememberedSet();
-
- RETURN ( __lifoRememberedSet() );
-%}
- "
- ObjectMemory lifoRememberedSet
- "
-!
-
-numberOfWeakObjects
- "return the number of weak objects in the system"
-
-%{ /* NOCONTEXT */
- extern int __weakListSize();
-
- RETURN ( __MKSMALLINT(__weakListSize()) );
-%}
- "
- ObjectMemory numberOfWeakObjects
- "
-!
-
-numberOfObjects
- "return the number of objects in the system."
-
- |tally "{ Class: SmallInteger }"|
-
- tally := 0.
- self allObjectsDo:[:obj | tally := tally + 1].
- ^ tally
-
- "
- ObjectMemory numberOfObjects
- "
-!
-
-collectObjectsWhich:aBlock
- "helper for the whoReferences queries. Returns a collection
- of objects for which aBlock returns true."
-
- |aCollection|
-
- aCollection := IdentitySet new.
- self allObjectsDo:[:o |
- (aBlock value:o) ifTrue:[
- aCollection add:o
- ]
- ].
- (aCollection size == 0) ifTrue:[
- "actually this cannot happen - there is always one"
- ^ nil
- ].
- ^ aCollection
-!
-
-whoReferences:anObject
- "return a collection of objects referencing the argument, anObject"
-
- ^ self collectObjectsWhich:[:o | o references:anObject]
-
- "
- (ObjectMemory whoReferences:Transcript) printNL
- "
-!
-
-whoReferencesInstancesOf:aClass
- "return a collection of objects refering to instances
- of the argument, aClass"
-
- ^ self collectObjectsWhich:[:o | o referencesInstanceOf:aClass]
-
- "
- (ObjectMemory whoReferencesInstancesOf:SystemBrowser) printNL
- "
-!
-
-whoReferencesDerivedInstancesOf:aClass
- "return a collection of objects refering to instances
- of the argument, aClass or a subclass of it."
-
- ^ self collectObjectsWhich:[:o | o referencesDerivedInstanceOf:aClass]
-
- "
- (ObjectMemory whoReferencesDerivedInstancesOf:View) printNL
- "
-!
-
-maximumIdentityHashValue
- "for ST-80 compatibility: return the maximum value
- a hashKey as returned by identityHash can get.
- Since ST/X uses direct pointers, a field in the objectHeader
- is used, which is currently 11 bits in size."
-
-%{ /* NOCONTEXT */
- RETURN ( __MKSMALLINT( __MAX_HASH__ << __HASH_SHIFT__) );
-%}
- "
- ObjectMemory maximumIdentityHashValue
- "
-! !
-
-!ObjectMemory class methodsFor:'debug queries'!
-
-printReferences:anObject
- "for debugging: print referents to anObject.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice
- use ObjectMemory>>whoReferences: or anObject>>allOwners."
-
-%{
- __printRefChain(__context, anObject);
-%}
-!
-
-dumpObject:someObject
- "low level dump an object.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{
- dumpObject(someObject);
-%}
- "
- ObjectMemory dumpObject:true
- ObjectMemory dumpObject:(Array new:10)
- ObjectMemory dumpObject:(10@20 corner:30@40)
- "
-!
-
-addressOf:anObject
- "return the core address of anObject as an integer
- - since objects may move around, the returned value is invalid after the
- next scavenge/collect.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* NOCONTEXT */
-
- if (! __isNonNilObject(anObject)) {
- RETURN ( nil );
- }
- if (((int)anObject >= _MIN_INT) && ((int)anObject <= _MAX_INT)) {
- RETURN ( _MKSMALLINT((int)anObject) );
- }
- RETURN ( _MKLARGEINT((int)anObject) );
-%}
- "
- |p|
- p := Point new.
- ((ObjectMemory addressOf:p) printStringRadix:16) printNL.
- ObjectMemory scavenge.
- ((ObjectMemory addressOf:p) printStringRadix:16) printNL.
- "
-!
-
-objectAt:anAddress
- "return whatever anAddress points to as object.
- BIG BIG DANGER ALERT:
- this method is only to be used for debugging ST/X itself
- - you can easily (and badly) crash the system.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
- |low high|
-
- low := anAddress bitAnd:16rFFFF.
- high := (anAddress bitShift:16) bitAnd:16rFFFF.
-%{
- if (__bothSmallInteger(low, high)) {
- RETURN ((OBJ)((_intVal(high) << 16) | _intVal(low)));
- }
-%}
-!
-
-sizeOf:anObject
- "return the size of anObject in bytes.
- (this is not the same as 'anObject size').
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* NOCONTEXT */
-
- RETURN ( __isNonNilObject(anObject) ? _MKSMALLINT(__qSize(anObject)) : _MKSMALLINT(0) )
-%}
- "
- |hist big nw|
-
- hist := Array new:100 withAll:0.
- big := 0.
- ObjectMemory allObjectsDo:[:o |
- nw := (ObjectMemory sizeOf:o) // 4 + 1.
- nw > 100 ifTrue:[
- big := big + 1
- ] ifFalse:[
- hist at:nw put:(hist at:nw) + 1
- ].
- ].
- hist printNL.
- big printNL
- "
-!
-
-ageOf:anObject
- "return the number of scavenges, an object has survived
- in new space.
- For old objects and living contexts, the returned number is invalid.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* NOCONTEXT */
-
- if (! __isNonNilObject(anObject)) {
- RETURN ( 0 );
- }
- RETURN ( _MKSMALLINT( _GET_AGE(anObject) ) );
-%}
- "
- |p|
- p := Point new.
- (ObjectMemory ageOf:p) printNL.
- ObjectMemory tenuringScavenge.
- (ObjectMemory spaceOf:p) printNL.
- ObjectMemory tenuringScavenge.
- (ObjectMemory spaceOf:p) printNL.
- ObjectMemory tenuringScavenge.
- (ObjectMemory spaceOf:p) printNL.
- ObjectMemory tenuringScavenge.
- (ObjectMemory spaceOf:p) printNL.
- "
-!
-
-flagsOf:anObject
- "For debugging only.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* NOCONTEXT */
-
- if (! __isNonNilObject(anObject)) {
- RETURN ( nil );
- }
- RETURN ( _MKSMALLINT( anObject->o_flags ) );
-%}
- "
-F_ISREMEMBERED 1 /* a new-space thing being refd by some oldSpace thing */
-F_ISFORWARDED 2 /* a forwarded object (you will never see this here) */
-F_DEREFERENCED 4 /* a collection after grow (not currently used) */
-F_ISONLIFOLIST 8 /* a non-lifo-context-referencing-obj already on list */
-F_MARK 16 /* mark bit for background collector */
- "
-
- "
- |arr|
-
- arr := Array new.
- arr at:1 put:([thisContext] value).
- (ObjectMemory flagsOf:anObject) printNL
- "
-!
-
-spaceOf:anObject
- "return the memory space, in which anObject is.
- - since objects may move between spaces,
- the returned value may be invalid after the next scavenge/collect.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* NOCONTEXT */
-
- if (! __isNonNilObject(anObject)) {
- RETURN ( nil );
- }
- RETURN ( _MKSMALLINT( __qSpace(anObject) ) );
-%}
-! !
-
-!ObjectMemory class methodsFor:'garbage collection'!
-
-scavenge
- "collect young objects, without aging (i.e. no tenure).
- Can be used to quickly get rid of shortly before allocated
- stuff. This is relatively fast (compared to oldspace collect).
-
- An example where a non-tenuring scavenge makes sense is when
- allocating some OperatingSystem resource (a Color, File or View)
- and the OS runs out of resources. In this case, the scavenge may
- free some ST-objects and therefore (by signalling the WeakArrays
- or Registries) free the OS resources too.
- Of course, only recently allocated resources will be freed this
- way. If none was freed, a full collect will be needed."
-%{
- __nonTenuringScavenge(__context);
-%}
-
- "
- ObjectMemory scavenge
- "
-!
-
-tenuringScavenge
- "collect newspace stuff, with aging (i.e. objects old enough
- will be moved into the oldSpace).
- Use this for debugging and testing only - the system performs
- this automatically when the newspace fills up.
- This is relatively fast (compared to oldspace collect)"
-%{
- __scavenge(__context);
-%}
-
- "
- ObjectMemory tenuringScavenge
- "
-!
-
-tenure
- "force all living new stuff into old-space - effectively making
- all living young objects become old objects immediately.
- This is relatively fast (compared to oldspace collect).
-
- This method should only be used in very special situations:
- for example, when building up some long-living data structure
- in a time critical application.
- To do so, you have to do a scavenge followed by a tenure after the
- objects are created. Be careful, to not reference any other chunk-
- data when calling for a tenure (this will lead to lots of garbage in
- the oldspace).
- In normal situations, explicit tenures are not needed."
-%{
- __tenure(__context);
-%}
-
- "
- ObjectMemory tenure
- "
- "
- ... build up long living objects ...
- ObjectMemory scavenge.
- ObjectMemory tenure
- ... continue - objects created above are now in oldSpace ...
- "
-!
-
-garbageCollect
- "search for and free garbage in the oldSpace.
- This can take a long time - especially, if paging is involved."
-
- "/ used to be
- "/ self compressingGarbageCollect
- "/ here; changed to default to markAndSweep
-
- self markAndSweep
-
- "
- ObjectMemory garbageCollect
+ ObjectMemory backgroundCollectorRunning
"
!
@@ -1859,32 +1132,18 @@
"
!
-markAndSweep
- "mark/sweep garbage collector.
- perform a full mark&sweep collect.
- Warning: this may take some time and it is NOT interruptable.
- If you want to do a collect from a background process, or have
- other things to do, better use #incrementalGC which is interruptable."
-%{
- __markAndSweep(__context);
-%}
+garbageCollect
+ "search for and free garbage in the oldSpace.
+ This can take a long time - especially, if paging is involved."
+
+ "/ used to be
+ "/ self compressingGarbageCollect
+ "/ here; changed to default to markAndSweep
+
+ self markAndSweep
"
- ObjectMemory markAndSweep
- "
-!
-
-reclaimSymbols
- "reclaim unused symbols;
- Unused symbols are (currently) not reclaimed automatically,
- but only upon request with this method.
- It takes some time to do this ... and it is NOT interruptable.
- Future versions may do this automatically, while garbage collecting."
-%{
- __reclaimSymbols(__context);
-%}
- "
- ObjectMemory reclaimSymbols
+ ObjectMemory garbageCollect
"
!
@@ -1901,6 +1160,42 @@
%}
!
+gcStepIfUseful
+ "If either the IncrementalGCLimit or the FreeSpaceGCLimits have been
+ reached, perform one incremental garbage collect step.
+ Return true, if more gcSteps are required to finish the cycle,
+ false if done with a gc round.
+ If no limit has been reached yet, do nothing and return false.
+ This is called by the ProcessorScheduler at idle times or by the
+ backgroundCollector."
+
+ |done limit|
+
+ Object abortSignal handle:[:ex |
+ "/ in case of abort (from the debugger),
+ "/ disable gcSteps.
+ done := true.
+ IncrementalGCLimit := FreeSpaceGCLimit := nil.
+ 'OBJMEM: IGC aborted; turning off incremental GC' errorPrintNL
+ ] do:[
+ limit := IncrementalGCLimit.
+ (limit notNil and:[self oldSpaceAllocatedSinceLastGC > limit]) ifTrue:[
+ done := ObjectMemory gcStep
+ ] ifFalse:[
+ limit := FreeSpaceGCLimit.
+ (limit notNil and:[(self freeSpace + self freeListSpace) < limit]) ifTrue:[
+ done := ObjectMemory gcStep.
+ done ifTrue:[
+ self moreOldSpaceIfUseful
+ ].
+ ] ifFalse:[
+ done := true
+ ]
+ ].
+ ].
+ ^ done not
+!
+
incrementalGC
"perform one round of incremental GC steps.
The overall effect of this method is (almost) the same as calling
@@ -1937,70 +1232,53 @@
"
!
-gcStepIfUseful
- "If either the IncrementalGCLimit or the FreeSpaceGCLimits have been
- reached, perform one incremental garbage collect step.
- Return true, if more gcSteps are required to finish the cycle,
- false if done with a gc round.
- If no limit has been reached yet, do nothing and return false.
- This is called by the ProcessorScheduler at idle times or by the
- backgroundCollector."
-
- |done limit|
-
- Object abortSignal handle:[:ex |
- "/ in case of abort (from the debugger),
- "/ disable gcSteps.
- done := true.
- IncrementalGCLimit := FreeSpaceGCLimit := nil.
- 'OBJMEM: IGC aborted; turning off incremental GC' errorPrintNL
- ] do:[
- limit := IncrementalGCLimit.
- (limit notNil and:[self oldSpaceAllocatedSinceLastGC > limit]) ifTrue:[
- done := ObjectMemory gcStep
- ] ifFalse:[
- limit := FreeSpaceGCLimit.
- (limit notNil and:[(self freeSpace + self freeListSpace) < limit]) ifTrue:[
- done := ObjectMemory gcStep.
- done ifTrue:[
- self moreOldSpaceIfUseful
- ].
- ] ifFalse:[
- done := true
- ]
- ].
- ].
- ^ done not
-!
-
-verboseGarbageCollect
- "perform a compressing garbage collect and show some informational
- output on the Transcript"
-
- |nBytesBefore nReclaimed value unit|
-
- nBytesBefore := self oldSpaceUsed.
- self compressingGarbageCollect.
- nReclaimed := nBytesBefore - self oldSpaceUsed.
- nReclaimed > 0 ifTrue:[
- nReclaimed > 1024 ifTrue:[
- nReclaimed > (1024 * 1024) ifTrue:[
- value := nReclaimed // (1024 * 1024).
- unit := ' Mb.'
- ] ifFalse:[
- value := nReclaimed // 1024.
- unit := ' Kb.'
- ]
- ] ifFalse:[
- value := nReclaimed.
- unit := ' bytes.'
- ].
- Transcript show:'reclaimed '; show:value printString.
- Transcript showCr:unit
- ]
+markAndSweep
+ "mark/sweep garbage collector.
+ perform a full mark&sweep collect.
+ Warning: this may take some time and it is NOT interruptable.
+ If you want to do a collect from a background process, or have
+ other things to do, better use #incrementalGC which is interruptable."
+%{
+ __markAndSweep(__context);
+%}
"
- ObjectMemory verboseGarbageCollect
+ ObjectMemory markAndSweep
+ "
+!
+
+reclaimSymbols
+ "reclaim unused symbols;
+ Unused symbols are (currently) not reclaimed automatically,
+ but only upon request with this method.
+ It takes some time to do this ... and it is NOT interruptable.
+ Future versions may do this automatically, while garbage collecting."
+%{
+ __reclaimSymbols(__context);
+%}
+ "
+ ObjectMemory reclaimSymbols
+ "
+!
+
+scavenge
+ "collect young objects, without aging (i.e. no tenure).
+ Can be used to quickly get rid of shortly before allocated
+ stuff. This is relatively fast (compared to oldspace collect).
+
+ An example where a non-tenuring scavenge makes sense is when
+ allocating some OperatingSystem resource (a Color, File or View)
+ and the OS runs out of resources. In this case, the scavenge may
+ free some ST-objects and therefore (by signalling the WeakArrays
+ or Registries) free the OS resources too.
+ Of course, only recently allocated resources will be freed this
+ way. If none was freed, a full collect will be needed."
+%{
+ __nonTenuringScavenge(__context);
+%}
+
+ "
+ ObjectMemory scavenge
"
!
@@ -2074,170 +1352,100 @@
"
!
-backgroundCollectorRunning
- "return true, if a backgroundCollector is running"
-
- ^ BackgroundCollectProcess notNil
+tenure
+ "force all living new stuff into old-space - effectively making
+ all living young objects become old objects immediately.
+ This is relatively fast (compared to oldspace collect).
+
+ This method should only be used in very special situations:
+ for example, when building up some long-living data structure
+ in a time critical application.
+ To do so, you have to do a scavenge followed by a tenure after the
+ objects are created. Be careful, to not reference any other chunk-
+ data when calling for a tenure (this will lead to lots of garbage in
+ the oldspace).
+ In normal situations, explicit tenures are not needed."
+%{
+ __tenure(__context);
+%}
"
- ObjectMemory backgroundCollectorRunning
+ ObjectMemory tenure
+ "
+ "
+ ... build up long living objects ...
+ ObjectMemory scavenge.
+ ObjectMemory tenure
+ ... continue - objects created above are now in oldSpace ...
+ "
+!
+
+tenuringScavenge
+ "collect newspace stuff, with aging (i.e. objects old enough
+ will be moved into the oldSpace).
+ Use this for debugging and testing only - the system performs
+ this automatically when the newspace fills up.
+ This is relatively fast (compared to oldspace collect)"
+%{
+ __scavenge(__context);
+%}
+
+ "
+ ObjectMemory tenuringScavenge
+ "
+!
+
+verboseGarbageCollect
+ "perform a compressing garbage collect and show some informational
+ output on the Transcript"
+
+ |nBytesBefore nReclaimed value unit|
+
+ nBytesBefore := self oldSpaceUsed.
+ self compressingGarbageCollect.
+ nReclaimed := nBytesBefore - self oldSpaceUsed.
+ nReclaimed > 0 ifTrue:[
+ nReclaimed > 1024 ifTrue:[
+ nReclaimed > (1024 * 1024) ifTrue:[
+ value := nReclaimed // (1024 * 1024).
+ unit := ' Mb.'
+ ] ifFalse:[
+ value := nReclaimed // 1024.
+ unit := ' Kb.'
+ ]
+ ] ifFalse:[
+ value := nReclaimed.
+ unit := ' bytes.'
+ ].
+ Transcript show:'reclaimed '; show:value printString.
+ Transcript showCr:unit
+ ]
+
+ "
+ ObjectMemory verboseGarbageCollect
"
! !
!ObjectMemory class methodsFor:'garbage collector control'!
-freeSpaceGCLimit:aNumber
- "set the freeSpace limit for incremental GC activation.
- The system will start doing incremental background GC, once less than this number
- of bytes are available for allocation.
- The default is nil; setting it to nil will turn this trigger off."
-
- FreeSpaceGCLimit := aNumber
-
- "
- the following will start the incrementalGC (in the background)
- whenever the freeSpace drops below 1meg of free space
- "
- "
- ObjectMemory freeSpaceGCLimit:1000000.
- "
-
- "
- turn it off (i.e. let the system hit the wall ...)
- "
- "
- ObjectMemory freeSpaceGCLimit:nil.
- "
-!
-
-freeSpaceGCAmount:aNumber
- "set the amount to be allocated if, after an incrementalGC,
- not at least FreeSpaceGCLimit bytes are available for allocation.
- The amount should be greater than the limit, otherwise the incremental
- GC may try over and over to get the memory (actually waisting time)."
-
- FreeSpaceGCAmount := aNumber
-
- "
- the following will try to always keep at least 1meg of free space
- (in the background) and start to do so, whenever the freeSpace drops
- below 250k.
- "
- "
- ObjectMemory freeSpaceGCLimit:250000.
- ObjectMemory freeSpaceGCAmount:1000000.
- "
-
- "
- turn it off (i.e. let the system compute an appropriate amount ...)
- "
- "
- ObjectMemory freeSpaceGCAmount:nil.
- "
-!
-
-freeSpaceGCLimit
- "return the freeSpace limit for incremental GC activation.
- The system will start doing incremental background GC, once less than this number
- of bytes are available in the compact free space.
- The default is 100000; setting it to nil will turn this trigger off."
-
- ^ FreeSpaceGCLimit
-
- "
- ObjectMemory freeSpaceGCLimit
- "
-!
-
-freeSpaceGCAmount
- "return the amount to be allocated if, after an incrementalGC,
- not at least FreeSpaceGCLimit bytes are available for allocation.
- The default is nil, which lets the system compute an abbpropriate value"
-
- ^ FreeSpaceGCAmount
+announceOldSpaceNeed:howMuch
+ "announce to the memory system, that howMuch bytes of memory will be needed
+ soon, which is going to live longer (whatever that means).
+ It first checks if the memory can be allocated without forcing a compressing
+ GC. If not, the oldSpace is increased. This may also lead to a slow compressing
+ collect. However, many smaller increases are avoided afterwards. Calling this
+ method before allocating huge chunks of data may provide better overall performance.
+ Notice: this is a nonstandard interface - use only in special situations."
+
+ (self checkForFastNew:howMuch) ifFalse:[
+ self incrementalGC.
+ (self checkForFastNew:howMuch) ifFalse:[
+ self moreOldSpace:howMuch
+ ]
+ ]
"
- ObjectMemory freeSpaceGCAmount
- "
-!
-
-incrementalGCLimit:aNumber
- "set the allocatedSinceLastGC limit for incremental GC activation.
- The system will start doing incremental background GC, once more than this number
- of bytes have been allocated since the last GC.
- The default is 500000; setting it to nil will turn this trigger off."
-
- IncrementalGCLimit := aNumber
-
- "
- ObjectMemory incrementalGCLimit:500000. 'do incr. GC very seldom'
- ObjectMemory incrementalGCLimit:100000. 'medium'
- ObjectMemory incrementalGCLimit:10000. 'do incr. GC very often'
- ObjectMemory incrementalGCLimit:nil. 'never'
- "
-!
-
-incrementalGCLimit
- "return the allocatedSinceLastGC limit for incremental GC activation.
- The system will start doing incremental background GC, once more than this number
- of bytes have been allocated since the last GC.
- The default is 500000; setting it to nil will turn this trigger off."
-
- ^ IncrementalGCLimit
-
- "
- ObjectMemory incrementalGCLimit
- "
-!
-
-moreOldSpaceIfUseful
- "to be called after an incremental GC cycle;
- if freeSpace is still below limit, allocate more oldSpace"
-
- |limit free amount|
-
- limit := FreeSpaceGCLimit.
- limit notNil ifTrue:[
- "/ if reclaimed space is below limit, we have to allocate more
- "/ oldSpace, to avoid excessive gcSteps (due to freeSpaceLimit
- "/ still not reached)
- "/
- free := self freeSpace + self freeListSpace.
- free < (limit * 3 // 2) ifTrue:[
- amount := FreeSpaceGCAmount.
- amount isNil ifTrue:[
- amount := limit * 3 // 2.
- ].
- 'OBJECTMEMORY: moreOldSpace to satisfy free-limit' infoPrintNL.
- (self moreOldSpace:(amount - free + (64*1024))) ifFalse:[
- "/
- "/ could not increase oldspace; reset FreeSpaceGCLimit to avoid
- "/ useless retries
- 'OBJECTMEMORY: could not increase oldSpace - reset limit' errorPrintNL.
- FreeSpaceGCLimit := nil
- ]
- ].
- ].
-!
-
-moreOldSpace:howMuch
- "allocate howMuch bytes more for old objects; return true if this worked,
- false if that failed.
- This is done automatically, when running out of space, but makes
- sense, if its known in advance that a lot of memory is needed to
- avoid multiple reallocations and compresses.
- On systems which do not support the mmap (or equivalent) system call,
- this (currently) implies a compressing garbage collect - so its slow.
- Notice: this is a nonstandard interface - use only in special situations."
-
-%{
- if (__isSmallInteger(howMuch)) {
- RETURN( __moreOldSpace(__context, _intVal(howMuch)) ? true : false );
- }
- RETURN (false);
-%}
- "
- ObjectMemory moreOldSpace:1000000
+ ObjectMemory announceOldSpaceNeed:1000000
"
!
@@ -2268,85 +1476,50 @@
"
!
-announceOldSpaceNeed:howMuch
- "announce to the memory system, that howMuch bytes of memory will be needed
- soon, which is going to live longer (whatever that means).
- It first checks if the memory can be allocated without forcing a compressing
- GC. If not, the oldSpace is increased. This may also lead to a slow compressing
- collect. However, many smaller increases are avoided afterwards. Calling this
- method before allocating huge chunks of data may provide better overall performance.
- Notice: this is a nonstandard interface - use only in special situations."
-
- (self checkForFastNew:howMuch) ifFalse:[
- self incrementalGC.
- (self checkForFastNew:howMuch) ifFalse:[
- self moreOldSpace:howMuch
- ]
- ]
-
- "
- ObjectMemory announceOldSpaceNeed:1000000
- "
-!
-
-oldSpaceIncrement
- "return the oldSpaceIncrement value. Thats the amount by which
- more memory is allocated in case the oldSpace gets filled up.
- In normal situations, the default value used in the VM is fine
- and there is no need to change it."
+avoidTenure:flag
+ "set/clear the avoidTenure flag. If set, aging of newSpace is turned off
+ as long as the newSpace fill-grade stays below some magic high-water mark.
+ If off (the default), aging is done as usual.
+ If the flag is turned on, scavenge may be a bit slower, due to more
+ objects being copied around. However, chances are high that in an idle
+ or (almost idle) system, less objects are moved into oldSpace.
+ Therefore, this helps to avoid oldSpace colelcts, in systems which go into
+ some standby mode and are reactivated by some external event.
+ (the avoid-flag should be turned off there, and set again once the idle loop
+ is reentered).
+
+ This is an EXPERIMENTAL interface."
%{ /* NOCONTEXT */
- extern unsigned __oldSpaceIncrement();
-
- RETURN (_MKSMALLINT( __oldSpaceIncrement(-1) ));
+ __avoidTenure(flag == true ? 1 : 0);
%}
- "
- ObjectMemory oldSpaceIncrement
- "
!
-oldSpaceIncrement:amount
- "set the oldSpaceIncrement value. Thats the amount by which
- more memory is allocated in case the oldSpace gets filled up.
- In normal situations, the default value used in the VM is fine
- and there is no need to change it. This method returns the
- previous increment value."
+checkForFastNew:amount
+ "this method returns true, if amount bytes could be allocated
+ quickly (i.e. without forcing a full GC or compress).
+ This can be used for smart background processes, which want to
+ allocate big chunks of data without disturbing foreground processes
+ too much. Such a process would check for fast-allocation, and perform
+ incremental GC-steps if required. Thus, avoiding the long blocking pause
+ due to a forced (non-incremental) GC.
+ Especially: doing so will not block higher priority foreground processes.
+ See an example use in Behavior>>niceBasicNew:.
+ This is experimental and not guaranteed to be in future versions."
%{ /* NOCONTEXT */
- extern unsigned __oldSpaceIncrement();
+ extern int __checkForFastNew();
if (__isSmallInteger(amount)) {
- RETURN (_MKSMALLINT( __oldSpaceIncrement(_intVal(amount)) ));
+ if (! __checkForFastNew(_intVal(amount))) {
+ RETURN (false);
+ }
}
-%}
- "to change increment to 1Meg:"
- "
- ObjectMemory oldSpaceIncrement:1024*1024
- "
+
+%}.
+ ^ true
!
-oldSpaceCompressLimit:amount
- "set the limit for oldSpace compression. If more memory than this
- limit is in use, the system will not perform compresses on the oldspace,
- but instead do a mark&sweep GC followed by an oldSpace increase if not enough
- could be reclaimed. The default is currently some 8Mb, which is ok for workstations
- with 16..32Mb of physical memory. If your system has much more physical RAM,
- you may want to increase this limit.
- This method returns the previous increment value."
-
-%{ /* NOCONTEXT */
- extern unsigned __compressingGCLimit();
-
- if (__isSmallInteger(amount)) {
- RETURN (_MKSMALLINT( __compressingGCLimit(_intVal(amount)) ));
- }
-%}
- "to change the limit to 12Mb:"
- "
- ObjectMemory oldSpaceCompressLimit:12*1024*1024
- "
-!
-
fastMoreOldSpaceAllocation:aBoolean
"this method turns on/off fastMoreOldSpace allocation.
By default, this is turned off (false), which means that in case of
@@ -2421,80 +1594,108 @@
"
!
-checkForFastNew:amount
- "this method returns true, if amount bytes could be allocated
- quickly (i.e. without forcing a full GC or compress).
- This can be used for smart background processes, which want to
- allocate big chunks of data without disturbing foreground processes
- too much. Such a process would check for fast-allocation, and perform
- incremental GC-steps if required. Thus, avoiding the long blocking pause
- due to a forced (non-incremental) GC.
- Especially: doing so will not block higher priority foreground processes.
- See an example use in Behavior>>niceBasicNew:.
- This is experimental and not guaranteed to be in future versions."
-
-%{ /* NOCONTEXT */
- extern int __checkForFastNew();
-
- if (__isSmallInteger(amount)) {
- if (! __checkForFastNew(_intVal(amount))) {
- RETURN (false);
- }
- }
-
-%}.
- ^ true
+freeSpaceGCAmount
+ "return the amount to be allocated if, after an incrementalGC,
+ not at least FreeSpaceGCLimit bytes are available for allocation.
+ The default is nil, which lets the system compute an abbpropriate value"
+
+ ^ FreeSpaceGCAmount
+
+ "
+ ObjectMemory freeSpaceGCAmount
+ "
+!
+
+freeSpaceGCAmount:aNumber
+ "set the amount to be allocated if, after an incrementalGC,
+ not at least FreeSpaceGCLimit bytes are available for allocation.
+ The amount should be greater than the limit, otherwise the incremental
+ GC may try over and over to get the memory (actually waisting time)."
+
+ FreeSpaceGCAmount := aNumber
+
+ "
+ the following will try to always keep at least 1meg of free space
+ (in the background) and start to do so, whenever the freeSpace drops
+ below 250k.
+ "
+ "
+ ObjectMemory freeSpaceGCLimit:250000.
+ ObjectMemory freeSpaceGCAmount:1000000.
+ "
+
+ "
+ turn it off (i.e. let the system compute an appropriate amount ...)
+ "
+ "
+ ObjectMemory freeSpaceGCAmount:nil.
+ "
+!
+
+freeSpaceGCLimit
+ "return the freeSpace limit for incremental GC activation.
+ The system will start doing incremental background GC, once less than this number
+ of bytes are available in the compact free space.
+ The default is 100000; setting it to nil will turn this trigger off."
+
+ ^ FreeSpaceGCLimit
+
+ "
+ ObjectMemory freeSpaceGCLimit
+ "
!
-turnGarbageCollectorOff
- "turn off the generational garbage collector by forcing new objects to be
- allocated directly in oldSpace (instead of newSpace)
- WARNING:
- This is somewhat dangerous: if collector is turned off,
- and too many objects are created, the system may run into trouble
- (i.e. oldSpace becomes full) and be forced to perform a full mark&sweep
- or even a compressing collect - making the overall realtime behavior worse.
- Use this only for special purposes or when realtime behavior
- is required for a limited time period.
-
- OBSOLETE: this is no longer supported
- - it may be a no-operation by the time you read this."
-
-%{ /* NOCONTEXT */
- __allocForceSpace(OLDSPACE);
-%}
+freeSpaceGCLimit:aNumber
+ "set the freeSpace limit for incremental GC activation.
+ The system will start doing incremental background GC, once less than this number
+ of bytes are available for allocation.
+ The default is nil; setting it to nil will turn this trigger off."
+
+ FreeSpaceGCLimit := aNumber
+
+ "
+ the following will start the incrementalGC (in the background)
+ whenever the freeSpace drops below 1meg of free space
+ "
+ "
+ ObjectMemory freeSpaceGCLimit:1000000.
+ "
+
+ "
+ turn it off (i.e. let the system hit the wall ...)
+ "
+ "
+ ObjectMemory freeSpaceGCLimit:nil.
+ "
!
-turnGarbageCollectorOn
- "turn garbage collector on again (see ObjectMemory>>turnGarbageCollectorOff)"
-
-%{ /* NOCONTEXT */
- __allocForceSpace(9999);
-%}
+incrementalGCLimit
+ "return the allocatedSinceLastGC limit for incremental GC activation.
+ The system will start doing incremental background GC, once more than this number
+ of bytes have been allocated since the last GC.
+ The default is 500000; setting it to nil will turn this trigger off."
+
+ ^ IncrementalGCLimit
+
+ "
+ ObjectMemory incrementalGCLimit
+ "
!
-makeOld:anObject
- "move anObject into oldSpace.
- This method is for internal & debugging purposes only -
- it may vanish. Dont use it."
-%{
- if (__moveToOldSpace(anObject, __context) < 0) {
- RETURN (false);
- }
-%}.
- ^ true
-!
-
-tenureParameters:magic
- "this is pure magic and not for public eyes ...
- This method allows fine tuning the scavenger internals,
- in cooperation to some statistic & test programs.
- It is undocumented, secret and may vanish.
- If you play around here, the system may behave very strange."
-
-%{ /* NOCONTEXT */
- __tenureParams(magic);
-%}.
+incrementalGCLimit:aNumber
+ "set the allocatedSinceLastGC limit for incremental GC activation.
+ The system will start doing incremental background GC, once more than this number
+ of bytes have been allocated since the last GC.
+ The default is 500000; setting it to nil will turn this trigger off."
+
+ IncrementalGCLimit := aNumber
+
+ "
+ ObjectMemory incrementalGCLimit:500000. 'do incr. GC very seldom'
+ ObjectMemory incrementalGCLimit:100000. 'medium'
+ ObjectMemory incrementalGCLimit:10000. 'do incr. GC very often'
+ ObjectMemory incrementalGCLimit:nil. 'never'
+ "
!
lockTenure:flag
@@ -2526,39 +1727,67 @@
%}
!
-avoidTenure:flag
- "set/clear the avoidTenure flag. If set, aging of newSpace is turned off
- as long as the newSpace fill-grade stays below some magic high-water mark.
- If off (the default), aging is done as usual.
- If the flag is turned on, scavenge may be a bit slower, due to more
- objects being copied around. However, chances are high that in an idle
- or (almost idle) system, less objects are moved into oldSpace.
- Therefore, this helps to avoid oldSpace colelcts, in systems which go into
- some standby mode and are reactivated by some external event.
- (the avoid-flag should be turned off there, and set again once the idle loop
- is reentered).
-
- This is an EXPERIMENTAL interface."
-
-%{ /* NOCONTEXT */
- __avoidTenure(flag == true ? 1 : 0);
+makeOld:anObject
+ "move anObject into oldSpace.
+ This method is for internal & debugging purposes only -
+ it may vanish. Dont use it."
+%{
+ if (__moveToOldSpace(anObject, __context) < 0) {
+ RETURN (false);
+ }
+%}.
+ ^ true
+!
+
+moreOldSpace:howMuch
+ "allocate howMuch bytes more for old objects; return true if this worked,
+ false if that failed.
+ This is done automatically, when running out of space, but makes
+ sense, if its known in advance that a lot of memory is needed to
+ avoid multiple reallocations and compresses.
+ On systems which do not support the mmap (or equivalent) system call,
+ this (currently) implies a compressing garbage collect - so its slow.
+ Notice: this is a nonstandard interface - use only in special situations."
+
+%{
+ if (__isSmallInteger(howMuch)) {
+ RETURN( __moreOldSpace(__context, _intVal(howMuch)) ? true : false );
+ }
+ RETURN (false);
%}
+ "
+ ObjectMemory moreOldSpace:1000000
+ "
!
-watchTenure:flag
- "set/clear the tenureWatch. If set, an internalError exception will be raised,
- whenever objects are tenured from newSpace into oldSpace
- (except for an explicit tenure request).
- This can be used to validate that no oldSpace objects are created
- (i.e. the system operates fully in newSpace).
- Be careful, if the avoidTenure flag is not set,
- there will almost always be a tenure sooner or later.
-
- EXPERIMENTAL - no warranty"
-
-%{ /* NOCONTEXT */
- __watchTenure(flag == true ? 1 : 0);
-%}
+moreOldSpaceIfUseful
+ "to be called after an incremental GC cycle;
+ if freeSpace is still below limit, allocate more oldSpace"
+
+ |limit free amount|
+
+ limit := FreeSpaceGCLimit.
+ limit notNil ifTrue:[
+ "/ if reclaimed space is below limit, we have to allocate more
+ "/ oldSpace, to avoid excessive gcSteps (due to freeSpaceLimit
+ "/ still not reached)
+ "/
+ free := self freeSpace + self freeListSpace.
+ free < (limit * 3 // 2) ifTrue:[
+ amount := FreeSpaceGCAmount.
+ amount isNil ifTrue:[
+ amount := limit * 3 // 2.
+ ].
+ 'OBJECTMEMORY: moreOldSpace to satisfy free-limit' infoPrintNL.
+ (self moreOldSpace:(amount - free + (64*1024))) ifFalse:[
+ "/
+ "/ could not increase oldspace; reset FreeSpaceGCLimit to avoid
+ "/ useless retries
+ 'OBJECTMEMORY: could not increase oldSpace - reset limit' errorPrintNL.
+ FreeSpaceGCLimit := nil
+ ]
+ ].
+ ].
!
newSpaceSize:newSize
@@ -2595,15 +1824,386 @@
ObjectMemory newSpaceSize:400*1024
"
+!
+
+oldSpaceCompressLimit:amount
+ "set the limit for oldSpace compression. If more memory than this
+ limit is in use, the system will not perform compresses on the oldspace,
+ but instead do a mark&sweep GC followed by an oldSpace increase if not enough
+ could be reclaimed. The default is currently some 8Mb, which is ok for workstations
+ with 16..32Mb of physical memory. If your system has much more physical RAM,
+ you may want to increase this limit.
+ This method returns the previous increment value."
+
+%{ /* NOCONTEXT */
+ extern unsigned __compressingGCLimit();
+
+ if (__isSmallInteger(amount)) {
+ RETURN (_MKSMALLINT( __compressingGCLimit(_intVal(amount)) ));
+ }
+%}
+ "to change the limit to 12Mb:"
+ "
+ ObjectMemory oldSpaceCompressLimit:12*1024*1024
+ "
+!
+
+oldSpaceIncrement
+ "return the oldSpaceIncrement value. Thats the amount by which
+ more memory is allocated in case the oldSpace gets filled up.
+ In normal situations, the default value used in the VM is fine
+ and there is no need to change it."
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceIncrement();
+
+ RETURN (_MKSMALLINT( __oldSpaceIncrement(-1) ));
+%}
+ "
+ ObjectMemory oldSpaceIncrement
+ "
+!
+
+oldSpaceIncrement:amount
+ "set the oldSpaceIncrement value. Thats the amount by which
+ more memory is allocated in case the oldSpace gets filled up.
+ In normal situations, the default value used in the VM is fine
+ and there is no need to change it. This method returns the
+ previous increment value."
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceIncrement();
+
+ if (__isSmallInteger(amount)) {
+ RETURN (_MKSMALLINT( __oldSpaceIncrement(_intVal(amount)) ));
+ }
+%}
+ "to change increment to 1Meg:"
+ "
+ ObjectMemory oldSpaceIncrement:1024*1024
+ "
+!
+
+tenureParameters:magic
+ "this is pure magic and not for public eyes ...
+ This method allows fine tuning the scavenger internals,
+ in cooperation to some statistic & test programs.
+ It is undocumented, secret and may vanish.
+ If you play around here, the system may behave very strange."
+
+%{ /* NOCONTEXT */
+ __tenureParams(magic);
+%}.
+!
+
+turnGarbageCollectorOff
+ "turn off the generational garbage collector by forcing new objects to be
+ allocated directly in oldSpace (instead of newSpace)
+ WARNING:
+ This is somewhat dangerous: if collector is turned off,
+ and too many objects are created, the system may run into trouble
+ (i.e. oldSpace becomes full) and be forced to perform a full mark&sweep
+ or even a compressing collect - making the overall realtime behavior worse.
+ Use this only for special purposes or when realtime behavior
+ is required for a limited time period.
+
+ OBSOLETE: this is no longer supported
+ - it may be a no-operation by the time you read this."
+
+%{ /* NOCONTEXT */
+ __allocForceSpace(OLDSPACE);
+%}
+!
+
+turnGarbageCollectorOn
+ "turn garbage collector on again (see ObjectMemory>>turnGarbageCollectorOff)"
+
+%{ /* NOCONTEXT */
+ __allocForceSpace(9999);
+%}
+!
+
+watchTenure:flag
+ "set/clear the tenureWatch. If set, an internalError exception will be raised,
+ whenever objects are tenured from newSpace into oldSpace
+ (except for an explicit tenure request).
+ This can be used to validate that no oldSpace objects are created
+ (i.e. the system operates fully in newSpace).
+ Be careful, if the avoidTenure flag is not set,
+ there will almost always be a tenure sooner or later.
+
+ EXPERIMENTAL - no warranty"
+
+%{ /* NOCONTEXT */
+ __watchTenure(flag == true ? 1 : 0);
+%}
! !
-!ObjectMemory class ignoredMethodsFor:'object finalization'!
-
-allShadowObjectsDo:aBlock
- "evaluate the argument, aBlock for all known shadow objects"
-%{
- __allShadowObjectsDo(&aBlock COMMA_CON);
-%}
+!ObjectMemory class methodsFor:'interrupt handler access'!
+
+childSignalInterruptHandler
+ "return the handler for UNIX-death-of-a-childprocess-signal interrupts"
+
+ ^ ChildSignalInterruptHandler
+!
+
+customInterruptHandler
+ "return the handler for custom interrupts"
+
+ ^ CustomInterruptHandler
+!
+
+customInterruptHandler:aHandler
+ "set the handler for custom interrupts"
+
+ CustomInterruptHandler := aHandler
+!
+
+disposeInterruptHandler
+ "return the handler for object disposal interrupts"
+
+ ^ DisposeInterruptHandler
+!
+
+disposeInterruptHandler:aHandler
+ "set the handler for object disposal interrupts"
+
+ DisposeInterruptHandler := aHandler
+!
+
+errorInterruptHandler
+ "return the handler for display error interrupts"
+
+ ^ ErrorInterruptHandler
+!
+
+errorInterruptHandler:aHandler
+ "set the handler for display error interrupts"
+
+ ErrorInterruptHandler := aHandler
+!
+
+exceptionInterruptHandler
+ "return the handler for floating point exception interrupts"
+
+ ^ ExceptionInterruptHandler
+!
+
+internalErrorHandler
+ "return the handler for ST/X internal errors.
+ An internal error is reported for example when a methods
+ bytecode is not a ByteArray, the selector table is not an Array
+ etc.
+ Those should not occur in normal circumstances."
+
+ ^ InternalErrorHandler
+!
+
+ioInterruptHandler
+ "return the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
+
+ ^ IOInterruptHandler
+!
+
+ioInterruptHandler:aHandler
+ "set the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
+
+ IOInterruptHandler := aHandler
+!
+
+recursionInterruptHandler
+ "return the handler for recursion/stack overflow interrupts"
+
+ ^ RecursionInterruptHandler
+!
+
+recursionInterruptHandler:aHandler
+ "set the handler for recursion/stack overflow interrupts"
+
+ RecursionInterruptHandler := aHandler
+!
+
+registerErrorInterruptHandler:aHandler forID:errorIDSymbol
+ "register a handler"
+
+ RegisteredErrorInterruptHandlers isNil ifTrue:[
+ RegisteredErrorInterruptHandlers := IdentityDictionary new
+ ].
+ RegisteredErrorInterruptHandlers at:errorIDSymbol put:aHandler
+!
+
+registeredErrorInterruptHandlers
+ "return registered handlers"
+
+ ^ RegisteredErrorInterruptHandlers
+!
+
+signalInterruptHandler
+ "return the handler for UNIX-signal interrupts"
+
+ ^ SignalInterruptHandler
+!
+
+signalInterruptHandler:aHandler
+ "set the handler for UNIX-signal interrupts"
+
+ SignalInterruptHandler := aHandler
+!
+
+spyInterruptHandler
+ "return the handler for spy-timer interrupts"
+
+ ^ SpyInterruptHandler
+!
+
+spyInterruptHandler:aHandler
+ "set the handler for spy-timer interrupts"
+
+ SpyInterruptHandler := aHandler
+!
+
+stepInterruptHandler
+ "return the handler for single step interrupts"
+
+ ^ StepInterruptHandler
+!
+
+stepInterruptHandler:aHandler
+ "set the handler for single step interrupts"
+
+ StepInterruptHandler := aHandler
+!
+
+timerInterruptHandler
+ "return the handler for timer interrupts"
+
+ ^ TimerInterruptHandler
+!
+
+timerInterruptHandler:aHandler
+ "set the handler for timer interrupts"
+
+ TimerInterruptHandler := aHandler
+!
+
+userInterruptHandler
+ "return the handler for CNTL-C interrupt handling"
+
+ ^ UserInterruptHandler
+!
+
+userInterruptHandler:aHandler
+ "set the handler for CNTL-C interrupt handling"
+
+ UserInterruptHandler := aHandler
+! !
+
+!ObjectMemory class methodsFor:'interrupt statistics'!
+
+interruptLatency:ms receiver:rec class:cls selector:sel vmActivity:vmActivity
+ "example implementation of latencyTime monitoring:
+ This method simply measures the max-latency time.
+ You may want to use some other handler (see #interruptLatencyMonitor:)
+ and extract more information (blocking context).
+ DEMO Example."
+
+ ms > MaxInterruptLatency ifTrue:[
+ MaxInterruptLatency := ms.
+ 'IRQ-LATENCY: ' infoPrint. rec class infoPrint. ' ' infoPrint. sel infoPrint. '(' infoPrint. vmActivity infoPrint . ') ---> ' infoPrint. ms infoPrintNL.
+ ].
+ (InterruptLatencyGoal notNil and:[ms > InterruptLatencyGoal]) ifTrue:[
+ '*** IRQ REALTIME-DEADLINE MISSED: ' errorPrint.
+ rec isBehavior ifTrue:[
+ rec name errorPrint. 'class' errorPrint.
+ ] ifFalse:[
+ rec class errorPrint
+ ].
+ ' ' errorPrint. sel errorPrint. '(' errorPrint. vmActivity errorPrint . ') ---> ' errorPrint.
+ ms errorPrintNL.
+ ].
+
+ "to enable the demo handler:
+
+ ObjectMemory resetMaxInterruptLatency.
+ ObjectMemory interruptLatencyMonitor:ObjectMemory.
+ "
+ "to disable timing statistics:
+
+ ObjectMemory interruptLatencyMonitor:nil.
+ ObjectMemory maxInterruptLatency printNL.
+ "
+
+ "Created: 7.11.1995 / 21:05:50 / cg"
+ "Modified: 7.11.1995 / 21:13:33 / cg"
+!
+
+interruptLatencyGoal:millis
+ "setup to report an error message, whenever a realtime goal could not be
+ met due to blocked interrupts or long primitives or GC activity.
+ An argument of nil clears the check.
+ DEMO Example."
+
+ InterruptLatencyGoal := millis.
+ millis isNil ifTrue:[
+ InterruptLatencyMonitor := nil.
+ ] ifFalse:[
+ MaxInterruptLatency := 0.
+ InterruptLatencyMonitor := self.
+ ]
+
+ "
+ ObjectMemory interruptLatencyGoal:50
+ "
+!
+
+interruptLatencyMonitor
+ "return the interrupt-latency-monitor if any.
+ See comment in #interruptLatencyMonitor:.
+ This is a non-standard debugging/realtime instrumentation entry."
+
+ ^ InterruptLatencyMonitor
+!
+
+interruptLatencyMonitor:aHandler
+ "set the interrupt latency monitor. If non-nil, this one will be sent
+ an interruptLatency: message with the millisecond delay between
+ the interrupt and its handling.
+ This is a non-standard debugging/realtime instrumentation entry."
+
+ InterruptLatencyMonitor := aHandler
+!
+
+maxInterruptLatency
+ "return the maximum accumulated interrupt latency in millis.
+ DEMO Example."
+
+ ^ MaxInterruptLatency
+!
+
+resetMaxInterruptLatency
+ "reset the maximum accumulated interrupt latency probe time.
+ DEMO Example."
+
+ MaxInterruptLatency := 0
+! !
+
+!ObjectMemory class methodsFor:'low memory handling'!
+
+memoryInterrupt
+ "when a low-memory condition arises, ask all classes to
+ remove possibly cached data. You may help the system a bit,
+ in providing a lowSpaceCleanup method in your classes which have
+ lots of data kept somewhere (usually, cached data).
+ - this may or may not help."
+
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass lowSpaceCleanup
+ ].
+
+"/ self error:'almost out of memory'
+ 'almost out of memory' errorPrintNL.
+
+ LowSpaceSemaphore signalIf.
! !
!ObjectMemory class methodsFor:'object finalization'!
@@ -2616,14 +2216,6 @@
%}
!
-finalize
- "tell all weak objects that something happened."
-
- self allChangedShadowObjectsDo:[:aShadowArray |
- aShadowArray lostPointer.
- ]
-!
-
disposeInterrupt
"this is triggered by the garbage collector,
whenever any shadowArray looses a pointer."
@@ -2641,6 +2233,14 @@
]
!
+finalize
+ "tell all weak objects that something happened."
+
+ self allChangedShadowObjectsDo:[:aShadowArray |
+ aShadowArray lostPointer.
+ ]
+!
+
startBackgroundFinalizationAt:aPriority
"start a process doing finalization work in the background.
Can be used to reduce the pauses created by finalization.
@@ -2707,6 +2307,18 @@
!ObjectMemory class methodsFor:'physical memory access'!
+collectedOldSpacePagesDo:aBlock
+ "evaluates aBlock for all pages in the prev. oldSpace, passing
+ the pages address as argument.
+ For internal & debugging use only."
+%{
+ if (__collectedOldSpacePagesDo(&aBlock COMMA_CON) < 0) {
+ RETURN (false);
+ }
+%}.
+ ^ true
+!
+
newSpacePagesDo:aBlock
"evaluates aBlock for all pages in the newSpace, passing
the pages address as argument.
@@ -2731,18 +2343,6 @@
^ true
!
-collectedOldSpacePagesDo:aBlock
- "evaluates aBlock for all pages in the prev. oldSpace, passing
- the pages address as argument.
- For internal & debugging use only."
-%{
- if (__collectedOldSpacePagesDo(&aBlock COMMA_CON) < 0) {
- RETURN (false);
- }
-%}.
- ^ true
-!
-
pageIsInCore:aPageNumber
"return true, if the page (as enumerated via oldSpacePagesDo:)
is in memory; false, if currently paged out. For internal
@@ -2770,6 +2370,472 @@
^ true
! !
+!ObjectMemory class methodsFor:'queries'!
+
+bytesUsed
+ "return the number of bytes allocated for objects -
+ this number is not exact, since some objects may already be dead
+ (i.e. not yet reclaimed by the garbage collector).
+ If you need the exact number, you have to loop over all
+ objects and ask for the bytesize using ObjectMemory>>sizeOf:."
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceUsed(), __newSpaceUsed(), __freeListSpace();
+
+ RETURN ( _MKSMALLINT(__oldSpaceUsed() + __newSpaceUsed() - __freeListSpace()) );
+%}
+ "
+ ObjectMemory bytesUsed
+ "
+!
+
+collectObjectsWhich:aBlock
+ "helper for the whoReferences queries. Returns a collection
+ of objects for which aBlock returns true."
+
+ |aCollection|
+
+ aCollection := IdentitySet new.
+ self allObjectsDo:[:o |
+ (aBlock value:o) ifTrue:[
+ aCollection add:o
+ ]
+ ].
+ (aCollection size == 0) ifTrue:[
+ "actually this cannot happen - there is always one"
+ ^ nil
+ ].
+ ^ aCollection
+!
+
+fixSpaceSize
+ "return the total size of the fix space."
+
+%{ /* NOCONTEXT */
+ extern unsigned __fixSpaceSize();
+
+ RETURN ( _MKSMALLINT(__fixSpaceSize()) );
+%}
+ "
+ ObjectMemory fixSpaceSize
+ "
+!
+
+fixSpaceUsed
+ "return the number of bytes allocated for old objects in fix space."
+
+%{ /* NOCONTEXT */
+ extern unsigned __fixSpaceUsed();
+
+ RETURN ( _MKSMALLINT(__fixSpaceUsed()) );
+%}
+ "
+ ObjectMemory fixSpaceUsed
+ "
+!
+
+freeListSpace
+ "return the number of bytes in the free lists.
+ (which is included in oldSpaceUsed)"
+
+%{ /* NOCONTEXT */
+ extern unsigned __freeListSpace();
+
+ RETURN ( _MKSMALLINT(__freeListSpace()) );
+%}
+ "
+ ObjectMemory freeListSpace
+ "
+!
+
+freeSpace
+ "return the number of bytes in the compact free area.
+ (oldSpaceUsed + freeSpaceSize = oldSpaceSize)"
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceSize(), __oldSpaceUsed();
+
+ RETURN ( _MKSMALLINT(__oldSpaceSize() - __oldSpaceUsed()) );
+%}
+ "
+ ObjectMemory freeSpace
+ "
+!
+
+garbageCollectCount
+ "return the number of compressing collects that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __garbageCollectCount();
+
+ RETURN (_MKSMALLINT(__garbageCollectCount()));
+%}
+ "
+ ObjectMemory garbageCollectCount
+ "
+!
+
+incrementalGCCount
+ "return the number of incremental collects that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __incrementalGCCount();
+
+ RETURN (_MKSMALLINT(__incrementalGCCount()));
+%}
+ "
+ ObjectMemory incrementalGCCount
+ "
+!
+
+incrementalGCPhase
+ "returns the internal state of the incremental GC.
+ The meaning of those numbers is a secret :-).
+ (for the curious: (currently)
+ 2 is idle, 3..11 are various mark phases,
+ 12 is the sweep phase. 0 and 1 are cleanup phases when the
+ incr. GC gets interrupted by a full GC).
+ Do not depend on the values - there may be additional phases in
+ future versions (incremental compact ;-).
+ This is for debugging and monitoring only - and may change or vanish"
+
+%{ /* NOCONTEXT */
+ extern int __incrGCphase();
+
+ RETURN (_MKSMALLINT(__incrGCphase()));
+%}
+!
+
+lastScavengeReclamation
+ "returns the number of bytes replacimed by the last scavenge.
+ For statistic only - this may vanish."
+
+%{ /* NOCONTEXT */
+ extern int __newSpaceReclaimed();
+
+ RETURN ( _MKSMALLINT(__newSpaceReclaimed()) );
+%}
+ "percentage of reclaimed objects is returned by:
+
+ ((ObjectMemory lastScavengeReclamation)
+ / (ObjectMemory newSpaceSize)) * 100.0
+ "
+!
+
+lifoRememberedSet
+ "return the lifoRemSet.
+ This is pure VM debugging and will vanish without notice."
+
+%{ /* NOCONTEXT */
+ extern OBJ __lifoRememberedSet();
+
+ RETURN ( __lifoRememberedSet() );
+%}
+ "
+ ObjectMemory lifoRememberedSet
+ "
+!
+
+lifoRememberedSetSize
+ "return the size of the lifoRemSet.
+ This is a VM debugging interface and may vanish without notice."
+
+%{ /* NOCONTEXT */
+ extern int __lifoRememberedSetSize();
+
+ RETURN (_MKSMALLINT(__lifoRememberedSetSize()));
+%}
+ "
+ ObjectMemory lifoRememberedSetSize
+ "
+!
+
+markAndSweepCount
+ "return the number of mark&sweep collects that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __markAndSweepCount();
+
+ RETURN (_MKSMALLINT(__markAndSweepCount()));
+%}
+ "
+ ObjectMemory markAndSweepCount
+ "
+!
+
+maximumIdentityHashValue
+ "for ST-80 compatibility: return the maximum value
+ a hashKey as returned by identityHash can get.
+ Since ST/X uses direct pointers, a field in the objectHeader
+ is used, which is currently 11 bits in size."
+
+%{ /* NOCONTEXT */
+ RETURN ( __MKSMALLINT( __MAX_HASH__ << __HASH_SHIFT__) );
+%}
+ "
+ ObjectMemory maximumIdentityHashValue
+ "
+!
+
+minScavengeReclamation
+ "returns the number of bytes replacimed by the least effective scavenge.
+ For statistic only - this may vanish."
+
+%{ /* NOCONTEXT */
+ extern int __newSpaceReclaimedMin();
+
+ RETURN ( _MKSMALLINT(__newSpaceReclaimedMin()) );
+%}
+ "
+ ObjectMemory minScavengeReclamation
+ "
+!
+
+newSpaceSize
+ "return the total size of the new space - this is usually fix"
+
+%{ /* NOCONTEXT */
+ extern unsigned __newSpaceSize();
+
+ RETURN ( _MKSMALLINT(__newSpaceSize()) );
+%}
+ "
+ ObjectMemory newSpaceSize
+ "
+!
+
+newSpaceUsed
+ "return the number of bytes allocated for new objects.
+ The returned value is usually obsolete as soon as you do
+ something with it ..."
+
+%{ /* NOCONTEXT */
+ extern unsigned __newSpaceUsed();
+
+ RETURN ( _MKSMALLINT(__newSpaceUsed()) );
+%}
+ "
+ ObjectMemory newSpaceUsed
+ "
+!
+
+numberOfObjects
+ "return the number of objects in the system."
+
+ |tally "{ Class: SmallInteger }"|
+
+ tally := 0.
+ self allObjectsDo:[:obj | tally := tally + 1].
+ ^ tally
+
+ "
+ ObjectMemory numberOfObjects
+ "
+!
+
+numberOfWeakObjects
+ "return the number of weak objects in the system"
+
+%{ /* NOCONTEXT */
+ extern int __weakListSize();
+
+ RETURN ( __MKSMALLINT(__weakListSize()) );
+%}
+ "
+ ObjectMemory numberOfWeakObjects
+ "
+!
+
+oldSpaceAllocatedSinceLastGC
+ "return the number of bytes allocated for old objects since the
+ last oldspace garbage collect occured. This information is used
+ by ProcessorScheduler to decide when to start the incremental
+ background GC."
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceAllocatedSinceLastGC();
+
+ RETURN ( _MKSMALLINT(__oldSpaceAllocatedSinceLastGC()) );
+%}
+ "
+ ObjectMemory oldSpaceAllocatedSinceLastGC
+ "
+!
+
+oldSpaceSize
+ "return the total size of the old space. - may grow slowly"
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceSize();
+
+ RETURN ( _MKSMALLINT(__oldSpaceSize()) );
+%}
+ "
+ ObjectMemory oldSpaceSize
+ "
+!
+
+oldSpaceUsed
+ "return the number of bytes allocated for old objects.
+ (This includes the free lists)"
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceUsed();
+
+ RETURN ( _MKSMALLINT(__oldSpaceUsed()) );
+%}
+ "
+ ObjectMemory oldSpaceUsed
+ "
+!
+
+rememberedSetSize
+ "return the number of old objects referencing new ones.
+ This is a VM debugging interface and may vanish without notice."
+
+%{ /* NOCONTEXT */
+ extern int __rememberedSetSize();
+
+ RETURN (_MKSMALLINT(__rememberedSetSize()));
+%}
+ "
+ ObjectMemory rememberedSetSize
+ "
+!
+
+resetMinScavengeReclamation
+ "resets the number of bytes replacimed by the least effective scavenge.
+ For statistic only - this may vanish."
+
+%{ /* NOCONTEXT */
+ extern int __resetNewSpaceReclaimedMin();
+
+ __resetNewSpaceReclaimedMin();
+%}.
+ ^ self
+ "
+ ObjectMemory resetMinScavengeReclamation.
+ ObjectMemory minScavengeReclamation
+ "
+!
+
+runsSingleOldSpace
+ "return true, if the system runs in a single oldSpace or
+ false if not.
+ The memory system will always drop the second semispace when
+ running out of virtual memory, or the baker-limit is reached.
+ OBSOLETE:
+ the system may now decide at any time to switch between
+ single and double-space algorithms, depending on the overall memory
+ size. You will now almost always get false as result, since the
+ second semispace is only allocated when needed, and released
+ immediately afterwards.
+ "
+
+%{ /* NOCONTEXT */
+ extern int __runsSingleOldSpace();
+
+ RETURN ( (__runsSingleOldSpace() ? true : false) );
+%}
+ "
+ ObjectMemory runsSingleOldSpace
+ "
+!
+
+scavengeCount
+ "return the number of scavenges that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __scavengeCount();
+
+ RETURN (_MKSMALLINT(__scavengeCount()));
+%}
+ "
+ ObjectMemory scavengeCount
+ "
+!
+
+symSpaceSize
+ "return the total size of the sym space."
+
+%{ /* NOCONTEXT */
+ extern unsigned __symSpaceSize();
+
+ RETURN ( _MKSMALLINT(__symSpaceSize()) );
+%}
+ "
+ ObjectMemory symSpaceSize
+ "
+!
+
+symSpaceUsed
+ "return the number of bytes allocated for old objects in sym space."
+
+%{ /* NOCONTEXT */
+ extern unsigned __symSpaceUsed();
+
+ RETURN ( _MKSMALLINT(__symSpaceUsed()) );
+%}
+ "
+ ObjectMemory symSpaceUsed
+ "
+!
+
+tenureAge
+ "return the current tenure age - thats the number of times
+ an object has to survive scavenges to be moved into oldSpace.
+ For statistic/debugging only - this method may vanish"
+
+%{ /* NOCONTEXT */
+ extern unsigned __tenureAge();
+
+ RETURN ( _MKSMALLINT(__tenureAge()) );
+%}
+!
+
+whoReferences:anObject
+ "return a collection of objects referencing the argument, anObject"
+
+ ^ self collectObjectsWhich:[:o | o references:anObject]
+
+ "
+ (ObjectMemory whoReferences:Transcript) printNL
+ "
+!
+
+whoReferencesDerivedInstancesOf:aClass
+ "return a collection of objects refering to instances
+ of the argument, aClass or a subclass of it."
+
+ ^ self collectObjectsWhich:[:o | o referencesDerivedInstanceOf:aClass]
+
+ "
+ (ObjectMemory whoReferencesDerivedInstancesOf:View) printNL
+ "
+!
+
+whoReferencesInstancesOf:aClass
+ "return a collection of objects refering to instances
+ of the argument, aClass"
+
+ ^ self collectObjectsWhich:[:o | o referencesInstanceOf:aClass]
+
+ "
+ (ObjectMemory whoReferencesInstancesOf:SystemBrowser) printNL
+ "
+! !
+
+!ObjectMemory class methodsFor:'semaphore access'!
+
+lowSpaceSemaphore
+ "return the semaphore that is signalled when the system detects a
+ low space condition. Usually, some time after this, an allocationFailure
+ will happen. You can have a cleanup process sitting in that semaphore and
+ start to release object."
+
+ ^ LowSpaceSemaphore
+! !
+
!ObjectMemory class methodsFor:'statistics'!
ageStatistic
@@ -2779,224 +2845,8 @@
%}
! !
-!ObjectMemory class methodsFor:'low memory handling'!
-
-memoryInterrupt
- "when a low-memory condition arises, ask all classes to
- remove possibly cached data. You may help the system a bit,
- in providing a lowSpaceCleanup method in your classes which have
- lots of data kept somewhere (usually, cached data).
- - this may or may not help."
-
- Smalltalk allBehaviorsDo:[:aClass |
- aClass lowSpaceCleanup
- ].
-
-"/ self error:'almost out of memory'
- 'almost out of memory' errorPrintNL.
-
- LowSpaceSemaphore signalIf.
-! !
-
!ObjectMemory class methodsFor:'system management'!
-loadClassBinary:aClassName
- "find the object file for aClassName and -if found - load it;
- this one loads precompiled object files"
-
- |fName newClass|
-
- fName := self fileNameForClass:aClassName.
- fName notNil ifTrue:[
- Class withoutUpdatingChangesDo:
- [
- self loadBinary:(fName , '.o')
- ].
- newClass := self at:(aClassName asSymbol).
- (newClass notNil and:[newClass implements:#initialize]) ifTrue:[
- newClass initialize
- ]
- ]
-!
-
-imageName
- "return the filename of the current image, or nil
- if not running from an image."
-
- ^ ImageName
-
- "
- ObjectMemory imageName
- "
-!
-
-imageBaseName
- "return a reasonable filename to use as baseName (i.e. without extension).
- This is the filename of the current image (without '.img') or,
- if not running from an image, the default name 'st'"
-
- |nm|
-
- nm := ImageName.
- (nm isNil or:[nm isBlank]) ifTrue:[
- ^ 'st'
- ].
- (nm endsWith:'.sav') ifTrue:[
- nm := nm copyWithoutLast:4
- ].
- (nm endsWith:'.img') ifTrue:[
- ^ nm copyWithoutLast:4
- ].
- ^ nm
-
- "
- ObjectMemory imageBaseName
- "
-!
-
-nameForSnapshot
- "return a reasonable filename to store the snapshot image into.
- This is the filename of the current image or,
- if not running from an image, the default name 'st.img'"
-
- ^ self imageBaseName , '.img'
-
- "
- ObjectMemory nameForSnapshot
- "
-!
-
-nameForSources
- "return a reasonable filename to store the sources into.
- This is the basename of the current image with '.img' replaced
- by '.src', or, if not running from an image, the default name 'st.src'"
-
- ^ self imageBaseName , '.src'
-
- "
- ObjectMemory nameForSources
- "
-!
-
-nameForChanges
- "return a reasonable filename to store the changes into.
- Currently, this is defined in a classVariable and defaults to 'changes'.
- In future versions, this will be the basename of the current image with '.img' replaced
- by '.chg', or, if not running from an image, the default name 'st.chg'."
-
- ChangeFileName notNil ifTrue:[^ ChangeFileName].
- ^ 'changes'.
-
-"/ future versions will have:
-"/ (requires some additionas at other places)
-"/
-"/ ^ self imageBaseName , '.chg'
-
- "
- ObjectMemory nameForChanges
- "
-!
-
-nameForChanges:aFilename
- "set the name of the file where changes are stored into."
-
- ChangeFileName := aFilename
-
- "
- ObjectMemory nameForChanges:'myChanges'
- "
-!
-
-snapShot
- "create a snapshot file containing all of the current state."
-
- self snapShotOn:(self nameForSnapshot)
-
- "
- ObjectMemory snapShot
- "
-!
-
-snapShotOn:aFileName
- "create a snapshot in the given file.
- If the file exists, save it for backup.
- Return true if the snapshot worked, false if it failed for some reason.
- Notify dependents before and after the snapshot operation."
-
- |ok oldImageName|
-
- "
- keep a save version - just in case something
- bad happens while writing the image.
- (could be st/x internal error or file-system errors etc)
- "
- (OperatingSystem isValidPath:aFileName) ifTrue:[
- OperatingSystem renameFile:aFileName to:(aFileName , '.sav').
- ].
-
- "
- give others a chance to fix things
- "
- self changed:#save. "/ will vanish ...
- self changed:#aboutToSnapshot. "/ ... for ST-80 compatibility
-
- "
- ST-80 compatibility; send #preSnapshot to all classes
- "
- Smalltalk allBehaviorsDo:[:aClass |
- aClass preSnapshot
- ].
-
- "
- save the name with it ...
- "
- oldImageName := ImageName.
- ImageName := aFileName.
- ok := self primSnapShotOn:aFileName.
- ImageName := oldImageName.
-
- ok ifTrue:[
- Class addChangeRecordForSnapshot:aFileName.
- ].
-
-
- "
- ST-80 compatibility; send #postSnapshot to all classes
- "
- Smalltalk allBehaviorsDo:[:aClass |
- aClass postSnapshot
- ].
- self changed:#finishedSnapshot. "/ ST-80 compatibility
- ^ ok
-
- "
- ObjectMemory snapShotOn:'myimage.img'
- "
-!
-
-primSnapShotOn:aFileName
- "create a snapshot in the given file.
- Low level entry. Does not notify classes or write an entry to
- the changes file. Also, no image backup is created. Returns true if
- the snapshot worked, false if it failed for some reason.
- This method should not be used in normal cases."
-
- |ok|
-
-%{ /* STACK:32000 */
-
- OBJ __snapShotOn();
- OBJ funny = @symbol(funnySnapshotSymbol);
-
- if (__isString(aFileName)) {
- __BLOCKINTERRUPTS();
- ok = __snapShotOn(__context, _stringVal(aFileName), funny);
- __UNBLOCKINTERRUPTS();
- }
-%}.
- ^ ok
-!
-
allBinaryModulesDo:aBlock
"internal private method - walk over all known binary
modules and evaluate aBlock for each entry.
@@ -3119,159 +2969,203 @@
"
"Modified: 30.8.1995 / 17:29:30 / claus"
-! !
-
-!ObjectMemory class ignoredMethodsFor:'system management'!
-
-applicationImageOn:aFileName for:startupClass selector:startupSelector
- "create a snapshot which will come up without any views
- but starts up an application by sending startupClass the startupSelector.
- This exists to nail down an idea I tried once.
- It is absolutely EXPERIMENTAL and unfinished. Dont use this method."
-
- |viewsKnown savedIdleBlocks savedTimeoutBlocks savedTranscript
- savedRoot|
-
- viewsKnown := Display knownViews.
- savedTranscript := Transcript.
- savedRoot := RootView.
-
- "a kludge: save image with modified knownViews,
- and also Transcript set to StdErr ..."
-
- Display knownViews:nil.
- RootView := nil.
-
- Transcript := Stderr.
- Smalltalk startupClass:startupClass selector:startupSelector arguments:nil.
- self snapShotOn:aFileName.
- Smalltalk startupClass:nil selector:nil arguments:nil.
-
- RootView := savedRoot.
- Transcript := savedTranscript.
- Display knownViews:viewsKnown.
+!
+
+imageBaseName
+ "return a reasonable filename to use as baseName (i.e. without extension).
+ This is the filename of the current image (without '.img') or,
+ if not running from an image, the default name 'st'"
+
+ |nm|
+
+ nm := ImageName.
+ (nm isNil or:[nm isBlank]) ifTrue:[
+ ^ 'st'
+ ].
+ (nm endsWith:'.sav') ifTrue:[
+ nm := nm copyWithoutLast:4
+ ].
+ (nm endsWith:'.img') ifTrue:[
+ ^ nm copyWithoutLast:4
+ ].
+ ^ nm
+
+ "
+ ObjectMemory imageBaseName
+ "
+!
+
+imageName
+ "return the filename of the current image, or nil
+ if not running from an image."
+
+ ^ ImageName
"
- ObjectMemory applicationImageOn:'draw.img' for:DrawTool selector:#start
+ ObjectMemory imageName
"
!
-minimumApplicationImageOn:aFileName for:startupClass selector:startupSelector
- "create a snapshot which will come up without any views
- but starts up an application by sending startupClass the startupSelector.
- All unneeded info is stripped from the saved image.
- This exists to nail down an idea I tried once.
- It is absolutely EXPERIMENTAL and unfinished. Dont use this method."
-
- "create a temporary image, for continuation"
- self snapShotOn:'temp.img'.
-
- Display knownViews do:[:aView |
- aView notNil ifTrue:[
- aView superView isNil ifTrue:[
- aView destroy
- ]
+loadClassBinary:aClassName
+ "find the object file for aClassName and -if found - load it;
+ this one loads precompiled object files"
+
+ |fName newClass|
+
+ fName := self fileNameForClass:aClassName.
+ fName notNil ifTrue:[
+ Class withoutUpdatingChangesDo:
+ [
+ self loadBinary:(fName , '.o')
+ ].
+ newClass := self at:(aClassName asSymbol).
+ (newClass notNil and:[newClass implements:#initialize]) ifTrue:[
+ newClass initialize
]
- ].
-
- self stripImage.
-
- self applicationImageOn:aFileName for:startupClass selector:startupSelector.
-
- "continue in old image"
-
- OperatingSystem exec:(Arguments at:1)
- withArguments:#('smalltalk' '-i' 'temp.img') , (Arguments copyFrom:2)
+ ]
+!
+
+nameForChanges
+ "return a reasonable filename to store the changes into.
+ Currently, this is defined in a classVariable and defaults to 'changes'.
+ In future versions, this will be the basename of the current image with '.img' replaced
+ by '.chg', or, if not running from an image, the default name 'st.chg'."
+
+ ChangeFileName notNil ifTrue:[^ ChangeFileName].
+ ^ 'changes'.
+
+"/ future versions will have:
+"/ (requires some additionas at other places)
+"/
+"/ ^ self imageBaseName , '.chg'
"
- ObjectMemory minimumApplicationImageOn:'draw1.img' for:DrawTool selector:#start
- ObjectMemory applicationImageOn:'draw2.img' for:DrawTool selector:#start
+ ObjectMemory nameForChanges
+ "
+!
+
+nameForChanges:aFilename
+ "set the name of the file where changes are stored into."
+
+ ChangeFileName := aFilename
+
+ "
+ ObjectMemory nameForChanges:'myChanges'
+ "
+!
+
+nameForSnapshot
+ "return a reasonable filename to store the snapshot image into.
+ This is the filename of the current image or,
+ if not running from an image, the default name 'st.img'"
+
+ ^ self imageBaseName , '.img'
+
+ "
+ ObjectMemory nameForSnapshot
"
!
-stripImage
- "remove all unneeded stuff from the image - much more is possible here.
- EXPERIMENTAL and unfinished. Dont use this method."
-
- "remove all class comments & source"
-
- Smalltalk allBehaviorsDo:[:aClass |
- aClass setComment:nil.
- aClass methodArray do:[:aMethod |
- aMethod source:''.
- aMethod category:#none
- ]
- ].
-
- "remove some developpers classes"
-
- Smalltalk at:#Compiler put:Parser.
- Smalltalk at:#Debugger put:MiniDebugger.
- Smalltalk at:#Inspector put:MiniInspector.
- Smalltalk at:#FileBrowser put:nil.
- Smalltalk at:#SystemBrowser put:nil.
- Debugger newDebugger.
-
- self garbageCollect
-! !
-
-!ObjectMemory class methodsFor:'ST-80 compatibility'!
-
-availableFreeBytes
- ^ self freeSpace + self freeListSpace
+nameForSources
+ "return a reasonable filename to store the sources into.
+ This is the basename of the current image with '.img' replaced
+ by '.src', or, if not running from an image, the default name 'st.src'"
+
+ ^ self imageBaseName , '.src'
"
- ObjectMemory availableFreeBytes
+ ObjectMemory nameForSources
+ "
+!
+
+primSnapShotOn:aFileName
+ "create a snapshot in the given file.
+ Low level entry. Does not notify classes or write an entry to
+ the changes file. Also, no image backup is created. Returns true if
+ the snapshot worked, false if it failed for some reason.
+ This method should not be used in normal cases."
+
+ |ok|
+
+%{ /* STACK:32000 */
+
+ OBJ __snapShotOn();
+ OBJ funny = @symbol(funnySnapshotSymbol);
+
+ if (__isString(aFileName)) {
+ __BLOCKINTERRUPTS();
+ ok = __snapShotOn(__context, _stringVal(aFileName), funny);
+ __UNBLOCKINTERRUPTS();
+ }
+%}.
+ ^ ok
+!
+
+snapShot
+ "create a snapshot file containing all of the current state."
+
+ self snapShotOn:(self nameForSnapshot)
+
+ "
+ ObjectMemory snapShot
"
!
-current
- ^ self
-!
-
-growMemoryBy:numberOfBytes
- ^ self moreOldSpace:numberOfBytes
-!
-
-numOopsNumBytes
- ^ Array with:(self numberOfObjects)
- with:(self bytesUsed)
+snapShotOn:aFileName
+ "create a snapshot in the given file.
+ If the file exists, save it for backup.
+ Return true if the snapshot worked, false if it failed for some reason.
+ Notify dependents before and after the snapshot operation."
+
+ |ok oldImageName|
+
+ "
+ keep a save version - just in case something
+ bad happens while writing the image.
+ (could be st/x internal error or file-system errors etc)
+ "
+ (OperatingSystem isValidPath:aFileName) ifTrue:[
+ OperatingSystem renameFile:aFileName to:(aFileName , '.sav').
+ ].
+
+ "
+ give others a chance to fix things
+ "
+ self changed:#save. "/ will vanish ...
+ self changed:#aboutToSnapshot. "/ ... for ST-80 compatibility
"
- ObjectMemory numOopsNumBytes
+ ST-80 compatibility; send #preSnapshot to all classes
"
-!
-
-bytesPerOOP
- "return the number of bytes an object reference (for example: an instvar)
- takes"
-
-%{ /* NOCONTEXT */
- RETURN(__MKSMALLINT(sizeof(OBJ)));
-%}
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass preSnapshot
+ ].
"
- ObjectMemory bytesPerOOP
+ save the name with it ...
"
-!
-
-bytesPerOTE
- "return the number of overhead bytes of an object.
- i.e. the number of bytes in every objects header."
-
-%{ /* NOCONTEXT */
- RETURN(__MKSMALLINT(OHDR_SIZE));
-%}
+ oldImageName := ImageName.
+ ImageName := aFileName.
+ ok := self primSnapShotOn:aFileName.
+ ImageName := oldImageName.
+
+ ok ifTrue:[
+ Class addChangeRecordForSnapshot:aFileName.
+ ].
+
"
- ObjectMemory bytesPerOTE
+ ST-80 compatibility; send #postSnapshot to all classes
"
-!
-
-globalCompactingGC
- self garbageCollect
-!
-
-compactingGC
- self garbageCollect
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass postSnapshot
+ ].
+ self changed:#finishedSnapshot. "/ ST-80 compatibility
+ ^ ok
+
+ "
+ ObjectMemory snapShotOn:'myimage.img'
+ "
! !
+
+ObjectMemory initialize!
--- a/ObjectMemory.st Thu Nov 23 02:52:35 1995 +0100
+++ b/ObjectMemory.st Thu Nov 23 03:01:22 1995 +0100
@@ -11,30 +11,61 @@
"
Object subclass:#ObjectMemory
- instanceVariableNames:''
- classVariableNames:'InternalErrorHandler UserInterruptHandler TimerInterruptHandler
- SpyInterruptHandler StepInterruptHandler ExceptionInterruptHandler
- ErrorInterruptHandler MemoryInterruptHandler SignalInterruptHandler
- ChildSignalInterruptHandler DisposeInterruptHandler
- RecursionInterruptHandler IOInterruptHandler
- CustomInterruptHandler
- RegisteredErrorInterruptHandlers
- InterruptLatencyMonitor
-
- AllocationFailureSignal MallocFailureSignal LowSpaceSemaphore
- IncrementalGCLimit FreeSpaceGCLimit FreeSpaceGCAmount
- BackgroundCollectProcess BackgroundFinalizationProcess
- FinalizationSemaphore
- Dependents
- ImageName ChangeFileName
-
- MaxInterruptLatency InterruptLatencyGoal'
- poolDictionaries:''
- category:'System-Support'
+ instanceVariableNames:''
+ classVariableNames:'InternalErrorHandler UserInterruptHandler TimerInterruptHandler
+ SpyInterruptHandler StepInterruptHandler
+ ExceptionInterruptHandler ErrorInterruptHandler
+ MemoryInterruptHandler SignalInterruptHandler
+ ChildSignalInterruptHandler DisposeInterruptHandler
+ RecursionInterruptHandler IOInterruptHandler
+ CustomInterruptHandler RegisteredErrorInterruptHandlers
+ InterruptLatencyMonitor AllocationFailureSignal
+ MallocFailureSignal LowSpaceSemaphore IncrementalGCLimit
+ FreeSpaceGCLimit FreeSpaceGCAmount BackgroundCollectProcess
+ BackgroundFinalizationProcess FinalizationSemaphore Dependents
+ ImageName ChangeFileName MaxInterruptLatency InterruptLatencyGoal'
+ poolDictionaries:''
+ category:'System-Support'
!
!ObjectMemory class methodsFor:'documentation'!
+caching
+"
+ The system uses various caches to speed up method-lookup.
+ Currently, there is a three-level cache hierarchy:
+
+ inline-cache keeps the target of the last send at the caller-
+ side (i.e. every send goes through its private
+ 1-slot inline-cache, where the address of the last
+ called function at this call location is kept.)
+
+ polymorph-inline-cache keeps a limited list of all targets ever reached
+ at this call location. The list is automatically
+ flushed if it grows too large, or the overall number
+ of poly-chache entries exceeds a limit.
+
+ method-lookup-cache a global cache. Hashes on class-selector pairs,
+ returning the target method.
+
+ Whenever methods are added or removed from the system, or the inheritance
+ hierarchy changes, some or all caches have to be flushed.
+ The flushXXX methods perform the task of flushing various caches.
+ All standard methods in Behavior call for cache flushing, when things change;
+ however, if you use the low level access methods in Behavior
+ (for example: #setSuperclass:) special care has to be taken.
+
+ In some situations, not all caches need flushing, for example a change
+ in an interpreted method (currently) needs no flushing of the inline caches.
+ Also, flushing can be limited to entries for a specific class for most changes.
+
+ To be 'on the brigth side of live', use ObjectMemory>>flushCaches (which
+ flushes all of them), when in doubt of which caches should be flushed.
+ It is better flush too much - otherwise you may end up in a wrong method after
+ a send.
+"
+!
+
copyright
"
COPYRIGHT (c) 1992 by Claus Gittinger
@@ -49,10 +80,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.77 1995-11-13 09:08:12 stefan Exp $'
-!
-
documentation
"
This class contains access methods to the system memory and the VM.
@@ -145,98 +172,6 @@
"
!
-caching
-"
- The system uses various caches to speed up method-lookup.
- Currently, there is a three-level cache hierarchy:
-
- inline-cache keeps the target of the last send at the caller-
- side (i.e. every send goes through its private
- 1-slot inline-cache, where the address of the last
- called function at this call location is kept.)
-
- polymorph-inline-cache keeps a limited list of all targets ever reached
- at this call location. The list is automatically
- flushed if it grows too large, or the overall number
- of poly-chache entries exceeds a limit.
-
- method-lookup-cache a global cache. Hashes on class-selector pairs,
- returning the target method.
-
- Whenever methods are added or removed from the system, or the inheritance
- hierarchy changes, some or all caches have to be flushed.
- The flushXXX methods perform the task of flushing various caches.
- All standard methods in Behavior call for cache flushing, when things change;
- however, if you use the low level access methods in Behavior
- (for example: #setSuperclass:) special care has to be taken.
-
- In some situations, not all caches need flushing, for example a change
- in an interpreted method (currently) needs no flushing of the inline caches.
- Also, flushing can be limited to entries for a specific class for most changes.
-
- To be 'on the brigth side of live', use ObjectMemory>>flushCaches (which
- flushes all of them), when in doubt of which caches should be flushed.
- It is better flush too much - otherwise you may end up in a wrong method after
- a send.
-"
-!
-
-interrupts
-"
- Handling of interrupts (i.e. unix-signals) is done via handler objects, which
- get a #XXXInterrupt-message sent. This is more flexible than (say) signalling
- a semaphore, since the handler-object may do anything to react on the signal
- (of course, it can also signal a semaphore to emulate the above behavior).
-
- Another reason for having handler objects is that they allow interrupt handling
- without any context switch, for high speed interrupt response.
- However, if you do this, special care is needed, since it is not defined,
- which process gets the interrupt and will do the processing (therefore,
- the default setup installs handlers which simply signal a semaphore and
- continue the running process).
-
- Typically, the handlers are set during early initialization of the system
- by sending 'ObjectMemory XXXInterruptHandler:aHandler' and not changed later.
- (see Smalltalk>>initialize or ProcessorScheduler>>initialize).
- To setup your own handler, create some object which responds to #xxxInterrupt,
- and make it the handler using the above method.
-
- Interrupt messages sent to handlers are:
- internalError:<someString> - internal interpreter/GC errors
- userInterrupt - ^C interrupt
- customInterrupt - custom interrupt
- ioInterrupt - SIGIO interrupt
- timerInterrupt - alarm timer (SIGALRM)
- errorInterrupt:<id> - errors from other primitives/subsystems
- (DisplayError)
- spyInterrupt - spy timer interrupt (SIGVTALARM)
- stepInterrupt - single step interrupt
- disposeInterrupt - finalization required
- recursionInterrupt - recursion (stack) overflow
- memoryInterrupt - soon running out of memory
- fpExceptionInterrupt - floating point exception (SIGFPE)
- childSignalInterrupt - death of a child process (SIGCHILD)
- signalInterrupt:<number> - unix signal (if other than above signals)
-
- To avoid frustration in case of badly set handlers, these messages
- are also implemented in the Object class - thus anything can be defined
- as interrupt handler. However, the VM will not send any
- interrupt message, if the corresonding handler object is nil
- (which means that nil is a bad choice, if you are interrested in the event).
-
- Interrupt processing is not immediately after the event arrives: there
- are certain ``save-places'' at which this handling is performed
- (message send, method return and loop-heads).
- If not explicitely enabled, primitive code is never interrupted.
-
- Interrupts may be disabled (OperatingSystem blockInterrupts) and reenabled
- (unblockInterrupts) to allow for critical data to be manipulated.
- Every process has its own interrupt-enable state which is switched
- when processes switch control (i.e. you cannot block interrupts across
- a suspend, delay etc.). However, the state will be restored after a resume.
-"
-!
-
garbageCollection
"
Currently, Smalltalk/X uses a two-level memory hierachy (actually, there
@@ -567,6 +502,66 @@
special features you are using - this provides the feedback required to decide
which methods are to be removed, kept or enhanced in future versions.
"
+!
+
+interrupts
+"
+ Handling of interrupts (i.e. unix-signals) is done via handler objects, which
+ get a #XXXInterrupt-message sent. This is more flexible than (say) signalling
+ a semaphore, since the handler-object may do anything to react on the signal
+ (of course, it can also signal a semaphore to emulate the above behavior).
+
+ Another reason for having handler objects is that they allow interrupt handling
+ without any context switch, for high speed interrupt response.
+ However, if you do this, special care is needed, since it is not defined,
+ which process gets the interrupt and will do the processing (therefore,
+ the default setup installs handlers which simply signal a semaphore and
+ continue the running process).
+
+ Typically, the handlers are set during early initialization of the system
+ by sending 'ObjectMemory XXXInterruptHandler:aHandler' and not changed later.
+ (see Smalltalk>>initialize or ProcessorScheduler>>initialize).
+ To setup your own handler, create some object which responds to #xxxInterrupt,
+ and make it the handler using the above method.
+
+ Interrupt messages sent to handlers are:
+ internalError:<someString> - internal interpreter/GC errors
+ userInterrupt - ^C interrupt
+ customInterrupt - custom interrupt
+ ioInterrupt - SIGIO interrupt
+ timerInterrupt - alarm timer (SIGALRM)
+ errorInterrupt:<id> - errors from other primitives/subsystems
+ (DisplayError)
+ spyInterrupt - spy timer interrupt (SIGVTALARM)
+ stepInterrupt - single step interrupt
+ disposeInterrupt - finalization required
+ recursionInterrupt - recursion (stack) overflow
+ memoryInterrupt - soon running out of memory
+ fpExceptionInterrupt - floating point exception (SIGFPE)
+ childSignalInterrupt - death of a child process (SIGCHILD)
+ signalInterrupt:<number> - unix signal (if other than above signals)
+
+ To avoid frustration in case of badly set handlers, these messages
+ are also implemented in the Object class - thus anything can be defined
+ as interrupt handler. However, the VM will not send any
+ interrupt message, if the corresonding handler object is nil
+ (which means that nil is a bad choice, if you are interrested in the event).
+
+ Interrupt processing is not immediately after the event arrives: there
+ are certain ``save-places'' at which this handling is performed
+ (message send, method return and loop-heads).
+ If not explicitely enabled, primitive code is never interrupted.
+
+ Interrupts may be disabled (OperatingSystem blockInterrupts) and reenabled
+ (unblockInterrupts) to allow for critical data to be manipulated.
+ Every process has its own interrupt-enable state which is switched
+ when processes switch control (i.e. you cannot block interrupts across
+ a suspend, delay etc.). However, the state will be restored after a resume.
+"
+!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.78 1995-11-23 02:01:22 cg Exp $'
! !
!ObjectMemory class methodsFor:'initialization'!
@@ -591,6 +586,67 @@
MemoryInterruptHandler := self
! !
+!ObjectMemory class methodsFor:'ST-80 compatibility'!
+
+availableFreeBytes
+ ^ self freeSpace + self freeListSpace
+
+ "
+ ObjectMemory availableFreeBytes
+ "
+!
+
+bytesPerOOP
+ "return the number of bytes an object reference (for example: an instvar)
+ takes"
+
+%{ /* NOCONTEXT */
+ RETURN(__MKSMALLINT(sizeof(OBJ)));
+%}
+
+ "
+ ObjectMemory bytesPerOOP
+ "
+!
+
+bytesPerOTE
+ "return the number of overhead bytes of an object.
+ i.e. the number of bytes in every objects header."
+
+%{ /* NOCONTEXT */
+ RETURN(__MKSMALLINT(OHDR_SIZE));
+%}
+
+ "
+ ObjectMemory bytesPerOTE
+ "
+!
+
+compactingGC
+ self garbageCollect
+!
+
+current
+ ^ self
+!
+
+globalCompactingGC
+ self garbageCollect
+!
+
+growMemoryBy:numberOfBytes
+ ^ self moreOldSpace:numberOfBytes
+!
+
+numOopsNumBytes
+ ^ Array with:(self numberOfObjects)
+ with:(self bytesUsed)
+
+ "
+ ObjectMemory numOopsNumBytes
+ "
+! !
+
!ObjectMemory class methodsFor:'Signal constants'!
allocationFailureSignal
@@ -607,41 +663,16 @@
^ MallocFailureSignal
! !
-!ObjectMemory class methodsFor:'semaphore access'!
-
-lowSpaceSemaphore
- "return the semaphore that is signalled when the system detects a
- low space condition. Usually, some time after this, an allocationFailure
- will happen. You can have a cleanup process sitting in that semaphore and
- start to release object."
-
- ^ LowSpaceSemaphore
-! !
-
!ObjectMemory class methodsFor:'VM messages'!
-infoPrinting:aBoolean
- "turn on/off various informational printouts in the VM.
- For example, the GC activity messages are controlled by
- this flags setting.
- The default is true, since (currently) those messages
- are useful for ST/X developers."
-
-%{ /* NOCONTEXT */
- extern int __infoPrinting;
-
- __infoPrinting = (aBoolean == true);
-%}
-!
-
-infoPrinting
- "return true, if various informational printouts in the VM
+debugPrinting
+ "return true, if various debug printouts in the VM
are turned on, false of off."
%{ /* NOCONTEXT */
- extern int __infoPrinting;
-
- RETURN (__infoPrinting ? true : false);
+ extern int __debugPrinting;
+
+ RETURN (__debugPrinting ? true : false);
%}
!
@@ -660,14 +691,324 @@
%}
!
-debugPrinting
- "return true, if various debug printouts in the VM
+infoPrinting
+ "return true, if various informational printouts in the VM
are turned on, false of off."
%{ /* NOCONTEXT */
- extern int __debugPrinting;
-
- RETURN (__debugPrinting ? true : false);
+ extern int __infoPrinting;
+
+ RETURN (__infoPrinting ? true : false);
+%}
+!
+
+infoPrinting:aBoolean
+ "turn on/off various informational printouts in the VM.
+ For example, the GC activity messages are controlled by
+ this flags setting.
+ The default is true, since (currently) those messages
+ are useful for ST/X developers."
+
+%{ /* NOCONTEXT */
+ extern int __infoPrinting;
+
+ __infoPrinting = (aBoolean == true);
+%}
+! !
+
+!ObjectMemory class methodsFor:'cache management'!
+
+flushCaches
+ "flush method and inline caches for all classes"
+
+%{ /* NOCONTEXT */
+ __flushMethodCache();
+ __flushAllInlineCaches();
+%}
+!
+
+flushCachesFor:aClass
+ "flush method and inline caches for aClass"
+
+%{ /* NOCONTEXT */
+ __flushMethodCacheFor(aClass);
+ __flushInlineCachesFor(aClass);
+%}
+!
+
+flushCachesForSelector:aSelector
+ "flush method and inline caches for aSelector"
+
+%{ /* NOCONTEXT */
+ __flushMethodCacheForSelector(aSelector);
+ __flushInlineCachesForSelector(aSelector);
+%}
+!
+
+flushInlineCaches
+ "flush all inlinecaches"
+
+%{ /* NOCONTEXT */
+ __flushAllInlineCaches();
+%}
+!
+
+flushInlineCachesFor:aClass withArgs:nargs
+ "flush inlinecaches for calls to aClass with nargs arguments"
+
+%{ /* NOCONTEXT */
+ __flushInlineCachesForAndNargs(aClass, _intVal(nargs));
+%}
+!
+
+flushInlineCachesForClass:aClass
+ "flush inlinecaches for calls to aClass."
+
+%{ /* NOCONTEXT */
+ __flushInlineCachesFor(aClass);
+%}
+!
+
+flushInlineCachesForSelector:aSelector
+ "flush inlinecaches for sends of aSelector"
+
+%{ /* NOCONTEXT */
+ __flushInlineCachesForSelector(aSelector);
+%}
+!
+
+flushInlineCachesWithArgs:nargs
+ "flush inlinecaches for calls with nargs arguments"
+
+%{ /* NOCONTEXT */
+ __flushInlineCaches(_intVal(nargs));
+%}
+!
+
+flushMethodCache
+ "flush the method cache"
+
+%{ /* NOCONTEXT */
+ __flushMethodCache();
+%}
+!
+
+flushMethodCacheFor:aClass
+ "flush the method cache for sends to aClass"
+
+%{ /* NOCONTEXT */
+ __flushMethodCacheFor(aClass);
+%}
+!
+
+flushMethodCacheForSelector:aSelector
+ "flush the method cache for sends of aSelector"
+
+%{ /* NOCONTEXT */
+ __flushMethodCacheForSelector(aSelector);
+%}
+!
+
+trapRestrictedMethods:trap
+ "Allow/Deny execution of restricted Methods (see Method>>>restricted:)
+
+ Notice: method restriction is a nonstandard feature, not supported
+ by other smalltalk implementations and not specified in the ANSI spec.
+ This is EXPERIMENTAL - and being evaluated for usability.
+ It may change or even vanish (if it shows to be not useful)."
+
+ |oldTrap|
+
+%{
+ if (__setTrapRestrictedMethods(trap == true))
+ oldTrap = true;
+ else
+ oldTrap = false;
+%}.
+
+ (trap and:[oldTrap not]) ifTrue:[
+ self flushCaches
+ ].
+ ^ oldTrap
+
+ "
+ ObjectMemory trapRestrictedMethods:true
+ ObjectMemory trapRestrictedMethods:false
+ "
+! !
+
+!ObjectMemory class methodsFor:'debug queries'!
+
+addressOf:anObject
+ "return the core address of anObject as an integer
+ - since objects may move around, the returned value is invalid after the
+ next scavenge/collect.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{ /* NOCONTEXT */
+
+ if (! __isNonNilObject(anObject)) {
+ RETURN ( nil );
+ }
+ if (((int)anObject >= _MIN_INT) && ((int)anObject <= _MAX_INT)) {
+ RETURN ( _MKSMALLINT((int)anObject) );
+ }
+ RETURN ( _MKLARGEINT((int)anObject) );
+%}
+ "
+ |p|
+ p := Point new.
+ ((ObjectMemory addressOf:p) printStringRadix:16) printNL.
+ ObjectMemory scavenge.
+ ((ObjectMemory addressOf:p) printStringRadix:16) printNL.
+ "
+!
+
+ageOf:anObject
+ "return the number of scavenges, an object has survived
+ in new space.
+ For old objects and living contexts, the returned number is invalid.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{ /* NOCONTEXT */
+
+ if (! __isNonNilObject(anObject)) {
+ RETURN ( 0 );
+ }
+ RETURN ( _MKSMALLINT( _GET_AGE(anObject) ) );
+%}
+ "
+ |p|
+ p := Point new.
+ (ObjectMemory ageOf:p) printNL.
+ ObjectMemory tenuringScavenge.
+ (ObjectMemory spaceOf:p) printNL.
+ ObjectMemory tenuringScavenge.
+ (ObjectMemory spaceOf:p) printNL.
+ ObjectMemory tenuringScavenge.
+ (ObjectMemory spaceOf:p) printNL.
+ ObjectMemory tenuringScavenge.
+ (ObjectMemory spaceOf:p) printNL.
+ "
+!
+
+dumpObject:someObject
+ "low level dump an object.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{
+ dumpObject(someObject);
+%}
+ "
+ ObjectMemory dumpObject:true
+ ObjectMemory dumpObject:(Array new:10)
+ ObjectMemory dumpObject:(10@20 corner:30@40)
+ "
+!
+
+flagsOf:anObject
+ "For debugging only.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{ /* NOCONTEXT */
+
+ if (! __isNonNilObject(anObject)) {
+ RETURN ( nil );
+ }
+ RETURN ( _MKSMALLINT( anObject->o_flags ) );
+%}
+ "
+F_ISREMEMBERED 1 /* a new-space thing being refd by some oldSpace thing */
+F_ISFORWARDED 2 /* a forwarded object (you will never see this here) */
+F_DEREFERENCED 4 /* a collection after grow (not currently used) */
+F_ISONLIFOLIST 8 /* a non-lifo-context-referencing-obj already on list */
+F_MARK 16 /* mark bit for background collector */
+ "
+
+ "
+ |arr|
+
+ arr := Array new.
+ arr at:1 put:([thisContext] value).
+ (ObjectMemory flagsOf:anObject) printNL
+ "
+!
+
+objectAt:anAddress
+ "return whatever anAddress points to as object.
+ BIG BIG DANGER ALERT:
+ this method is only to be used for debugging ST/X itself
+ - you can easily (and badly) crash the system.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+ |low high|
+
+ low := anAddress bitAnd:16rFFFF.
+ high := (anAddress bitShift:16) bitAnd:16rFFFF.
+%{
+ if (__bothSmallInteger(low, high)) {
+ RETURN ((OBJ)((_intVal(high) << 16) | _intVal(low)));
+ }
+%}
+!
+
+printReferences:anObject
+ "for debugging: print referents to anObject.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice
+ use ObjectMemory>>whoReferences: or anObject>>allOwners."
+
+%{
+ __printRefChain(__context, anObject);
+%}
+!
+
+sizeOf:anObject
+ "return the size of anObject in bytes.
+ (this is not the same as 'anObject size').
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{ /* NOCONTEXT */
+
+ RETURN ( __isNonNilObject(anObject) ? _MKSMALLINT(__qSize(anObject)) : _MKSMALLINT(0) )
+%}
+ "
+ |hist big nw|
+
+ hist := Array new:100 withAll:0.
+ big := 0.
+ ObjectMemory allObjectsDo:[:o |
+ nw := (ObjectMemory sizeOf:o) // 4 + 1.
+ nw > 100 ifTrue:[
+ big := big + 1
+ ] ifFalse:[
+ hist at:nw put:(hist at:nw) + 1
+ ].
+ ].
+ hist printNL.
+ big printNL
+ "
+!
+
+spaceOf:anObject
+ "return the memory space, in which anObject is.
+ - since objects may move between spaces,
+ the returned value may be invalid after the next scavenge/collect.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{ /* NOCONTEXT */
+
+ if (! __isNonNilObject(anObject)) {
+ RETURN ( nil );
+ }
+ RETURN ( _MKSMALLINT( __qSpace(anObject) ) );
%}
! !
@@ -706,150 +1047,8 @@
]
! !
-!ObjectMemory class methodsFor:'cache management'!
-
-flushInlineCachesForClass:aClass
- "flush inlinecaches for calls to aClass."
-
-%{ /* NOCONTEXT */
- __flushInlineCachesFor(aClass);
-%}
-!
-
-flushInlineCachesWithArgs:nargs
- "flush inlinecaches for calls with nargs arguments"
-
-%{ /* NOCONTEXT */
- __flushInlineCaches(_intVal(nargs));
-%}
-!
-
-flushInlineCachesFor:aClass withArgs:nargs
- "flush inlinecaches for calls to aClass with nargs arguments"
-
-%{ /* NOCONTEXT */
- __flushInlineCachesForAndNargs(aClass, _intVal(nargs));
-%}
-!
-
-flushInlineCachesForSelector:aSelector
- "flush inlinecaches for sends of aSelector"
-
-%{ /* NOCONTEXT */
- __flushInlineCachesForSelector(aSelector);
-%}
-!
-
-flushInlineCaches
- "flush all inlinecaches"
-
-%{ /* NOCONTEXT */
- __flushAllInlineCaches();
-%}
-!
-
-flushMethodCacheFor:aClass
- "flush the method cache for sends to aClass"
-
-%{ /* NOCONTEXT */
- __flushMethodCacheFor(aClass);
-%}
-!
-
-flushMethodCacheForSelector:aSelector
- "flush the method cache for sends of aSelector"
-
-%{ /* NOCONTEXT */
- __flushMethodCacheForSelector(aSelector);
-%}
-!
-
-flushMethodCache
- "flush the method cache"
-
-%{ /* NOCONTEXT */
- __flushMethodCache();
-%}
-!
-
-flushCachesFor:aClass
- "flush method and inline caches for aClass"
-
-%{ /* NOCONTEXT */
- __flushMethodCacheFor(aClass);
- __flushInlineCachesFor(aClass);
-%}
-!
-
-flushCachesForSelector:aSelector
- "flush method and inline caches for aSelector"
-
-%{ /* NOCONTEXT */
- __flushMethodCacheForSelector(aSelector);
- __flushInlineCachesForSelector(aSelector);
-%}
-!
-
-flushCaches
- "flush method and inline caches for all classes"
-
-%{ /* NOCONTEXT */
- __flushMethodCache();
- __flushAllInlineCaches();
-%}
-!
-
-trapRestrictedMethods:trap
- "Allow/Deny execution of restricted Methods (see Method>>>restricted:)
-
- Notice: method restriction is a nonstandard feature, not supported
- by other smalltalk implementations and not specified in the ANSI spec.
- This is EXPERIMENTAL - and being evaluated for usability.
- It may change or even vanish (if it shows to be not useful)."
-
- |oldTrap|
-
-%{
- if (__setTrapRestrictedMethods(trap == true))
- oldTrap = true;
- else
- oldTrap = false;
-%}.
-
- (trap and:[oldTrap not]) ifTrue:[
- self flushCaches
- ].
- ^ oldTrap
-
- "
- ObjectMemory trapRestrictedMethods:true
- ObjectMemory trapRestrictedMethods:false
- "
-! !
-
!ObjectMemory class methodsFor:'enumerating'!
-allObjectsDo:aBlock
- "evaluate the argument, aBlock for all objects in the system.
- There is one caveat: if a compressing oldSpace collect
- occurs while looping over the objects, the loop cannot be
- continued (for some internal reasons). In this case, false
- is returned."
-
- |work|
-
-%{ /* NOREGISTER - work may not be placed into a register here */
- __nonTenuringScavenge(__context);
- /*
- * allObjectsDo needs a temporary to hold newSpace objects
- */
- if (__allInstancesOfDo((OBJ *)0, &aBlock, &work COMMA_CON) < 0) {
- RETURN (false);
- }
-%}.
- ^ true
-!
-
allInstancesOf:aClass do:aBlock
"evaluate the argument, aBlock for all instances of aClass in the system.
There is one caveat: if a compressing oldSpace collect
@@ -871,6 +1070,27 @@
^ true
!
+allObjectsDo:aBlock
+ "evaluate the argument, aBlock for all objects in the system.
+ There is one caveat: if a compressing oldSpace collect
+ occurs while looping over the objects, the loop cannot be
+ continued (for some internal reasons). In this case, false
+ is returned."
+
+ |work|
+
+%{ /* NOREGISTER - work may not be placed into a register here */
+ __nonTenuringScavenge(__context);
+ /*
+ * allObjectsDo needs a temporary to hold newSpace objects
+ */
+ if (__allInstancesOfDo((OBJ *)0, &aBlock, &work COMMA_CON) < 0) {
+ RETURN (false);
+ }
+%}.
+ ^ true
+!
+
allOldObjectsDo:aBlock
"evaluate the argument, aBlock for all old objects in the system.
For debugging and tests only - do not use"
@@ -882,962 +1102,15 @@
^ true
! !
-!ObjectMemory class methodsFor:'interrupt handler access'!
-
-internalErrorHandler
- "return the handler for ST/X internal errors.
- An internal error is reported for example when a methods
- bytecode is not a ByteArray, the selector table is not an Array
- etc.
- Those should not occur in normal circumstances."
-
- ^ InternalErrorHandler
-!
-
-userInterruptHandler
- "return the handler for CNTL-C interrupt handling"
-
- ^ UserInterruptHandler
-!
-
-userInterruptHandler:aHandler
- "set the handler for CNTL-C interrupt handling"
-
- UserInterruptHandler := aHandler
-!
-
-timerInterruptHandler
- "return the handler for timer interrupts"
-
- ^ TimerInterruptHandler
-!
-
-timerInterruptHandler:aHandler
- "set the handler for timer interrupts"
-
- TimerInterruptHandler := aHandler
-!
-
-spyInterruptHandler
- "return the handler for spy-timer interrupts"
-
- ^ SpyInterruptHandler
-!
-
-spyInterruptHandler:aHandler
- "set the handler for spy-timer interrupts"
-
- SpyInterruptHandler := aHandler
-!
-
-stepInterruptHandler
- "return the handler for single step interrupts"
-
- ^ StepInterruptHandler
-!
-
-stepInterruptHandler:aHandler
- "set the handler for single step interrupts"
-
- StepInterruptHandler := aHandler
-!
-
-exceptionInterruptHandler
- "return the handler for floating point exception interrupts"
-
- ^ ExceptionInterruptHandler
-!
-
-errorInterruptHandler
- "return the handler for display error interrupts"
-
- ^ ErrorInterruptHandler
-!
-
-errorInterruptHandler:aHandler
- "set the handler for display error interrupts"
-
- ErrorInterruptHandler := aHandler
-!
-
-registeredErrorInterruptHandlers
- "return registered handlers"
-
- ^ RegisteredErrorInterruptHandlers
-!
-
-registerErrorInterruptHandler:aHandler forID:errorIDSymbol
- "register a handler"
-
- RegisteredErrorInterruptHandlers isNil ifTrue:[
- RegisteredErrorInterruptHandlers := IdentityDictionary new
- ].
- RegisteredErrorInterruptHandlers at:errorIDSymbol put:aHandler
-!
-
-signalInterruptHandler
- "return the handler for UNIX-signal interrupts"
-
- ^ SignalInterruptHandler
-!
-
-signalInterruptHandler:aHandler
- "set the handler for UNIX-signal interrupts"
-
- SignalInterruptHandler := aHandler
-!
-
-childSignalInterruptHandler
- "return the handler for UNIX-death-of-a-childprocess-signal interrupts"
-
- ^ ChildSignalInterruptHandler
-!
-
-disposeInterruptHandler
- "return the handler for object disposal interrupts"
-
- ^ DisposeInterruptHandler
-!
-
-disposeInterruptHandler:aHandler
- "set the handler for object disposal interrupts"
-
- DisposeInterruptHandler := aHandler
-!
-
-recursionInterruptHandler
- "return the handler for recursion/stack overflow interrupts"
-
- ^ RecursionInterruptHandler
-!
-
-recursionInterruptHandler:aHandler
- "set the handler for recursion/stack overflow interrupts"
-
- RecursionInterruptHandler := aHandler
-!
-
-ioInterruptHandler
- "return the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
-
- ^ IOInterruptHandler
-!
-
-ioInterruptHandler:aHandler
- "set the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
-
- IOInterruptHandler := aHandler
-!
-
-customInterruptHandler
- "return the handler for custom interrupts"
-
- ^ CustomInterruptHandler
-!
-
-customInterruptHandler:aHandler
- "set the handler for custom interrupts"
-
- CustomInterruptHandler := aHandler
-! !
-
-!ObjectMemory class methodsFor:'interrupt statistics'!
-
-interruptLatencyMonitor
- "return the interrupt-latency-monitor if any.
- See comment in #interruptLatencyMonitor:.
- This is a non-standard debugging/realtime instrumentation entry."
-
- ^ InterruptLatencyMonitor
-!
-
-interruptLatencyMonitor:aHandler
- "set the interrupt latency monitor. If non-nil, this one will be sent
- an interruptLatency: message with the millisecond delay between
- the interrupt and its handling.
- This is a non-standard debugging/realtime instrumentation entry."
-
- InterruptLatencyMonitor := aHandler
-!
-
-interruptLatency:ms receiver:rec class:cls selector:sel vmActivity:vmActivity
- "example implementation of latencyTime monitoring:
- This method simply measures the max-latency time.
- You may want to use some other handler (see #interruptLatencyMonitor:)
- and extract more information (blocking context).
- DEMO Example."
-
- ms > MaxInterruptLatency ifTrue:[
- MaxInterruptLatency := ms.
- 'IRQ-LATENCY: ' infoPrint. rec class infoPrint. ' ' infoPrint. sel infoPrint. '(' infoPrint. vmActivity infoPrint . ') ---> ' infoPrint. ms infoPrintNL.
- ].
- (InterruptLatencyGoal notNil and:[ms > InterruptLatencyGoal]) ifTrue:[
- '*** IRQ REALTIME-DEADLINE MISSED: ' errorPrint.
- rec isBehavior ifTrue:[
- rec name errorPrint. 'class' errorPrint.
- ] ifFalse:[
- rec class errorPrint
- ].
- ' ' errorPrint. sel errorPrint. '(' errorPrint. vmActivity errorPrint . ') ---> ' errorPrint.
- ms errorPrintNL.
- ].
-
- "to enable the demo handler:
-
- ObjectMemory resetMaxInterruptLatency.
- ObjectMemory interruptLatencyMonitor:ObjectMemory.
- "
- "to disable timing statistics:
-
- ObjectMemory interruptLatencyMonitor:nil.
- ObjectMemory maxInterruptLatency printNL.
- "
-
- "Created: 7.11.1995 / 21:05:50 / cg"
- "Modified: 7.11.1995 / 21:13:33 / cg"
-!
-
-resetMaxInterruptLatency
- "reset the maximum accumulated interrupt latency probe time.
- DEMO Example."
-
- MaxInterruptLatency := 0
-!
-
-interruptLatencyGoal:millis
- "setup to report an error message, whenever a realtime goal could not be
- met due to blocked interrupts or long primitives or GC activity.
- An argument of nil clears the check.
- DEMO Example."
-
- InterruptLatencyGoal := millis.
- millis isNil ifTrue:[
- InterruptLatencyMonitor := nil.
- ] ifFalse:[
- MaxInterruptLatency := 0.
- InterruptLatencyMonitor := self.
- ]
+!ObjectMemory class methodsFor:'garbage collection'!
+
+backgroundCollectorRunning
+ "return true, if a backgroundCollector is running"
+
+ ^ BackgroundCollectProcess notNil
"
- ObjectMemory interruptLatencyGoal:50
- "
-!
-
-maxInterruptLatency
- "return the maximum accumulated interrupt latency in millis.
- DEMO Example."
-
- ^ MaxInterruptLatency
-! !
-
-!ObjectMemory class methodsFor:'queries'!
-
-newSpaceSize
- "return the total size of the new space - this is usually fix"
-
-%{ /* NOCONTEXT */
- extern unsigned __newSpaceSize();
-
- RETURN ( _MKSMALLINT(__newSpaceSize()) );
-%}
- "
- ObjectMemory newSpaceSize
- "
-!
-
-oldSpaceSize
- "return the total size of the old space. - may grow slowly"
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceSize();
-
- RETURN ( _MKSMALLINT(__oldSpaceSize()) );
-%}
- "
- ObjectMemory oldSpaceSize
- "
-!
-
-symSpaceSize
- "return the total size of the sym space."
-
-%{ /* NOCONTEXT */
- extern unsigned __symSpaceSize();
-
- RETURN ( _MKSMALLINT(__symSpaceSize()) );
-%}
- "
- ObjectMemory symSpaceSize
- "
-!
-
-fixSpaceSize
- "return the total size of the fix space."
-
-%{ /* NOCONTEXT */
- extern unsigned __fixSpaceSize();
-
- RETURN ( _MKSMALLINT(__fixSpaceSize()) );
-%}
- "
- ObjectMemory fixSpaceSize
- "
-!
-
-newSpaceUsed
- "return the number of bytes allocated for new objects.
- The returned value is usually obsolete as soon as you do
- something with it ..."
-
-%{ /* NOCONTEXT */
- extern unsigned __newSpaceUsed();
-
- RETURN ( _MKSMALLINT(__newSpaceUsed()) );
-%}
- "
- ObjectMemory newSpaceUsed
- "
-!
-
-oldSpaceUsed
- "return the number of bytes allocated for old objects.
- (This includes the free lists)"
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceUsed();
-
- RETURN ( _MKSMALLINT(__oldSpaceUsed()) );
-%}
- "
- ObjectMemory oldSpaceUsed
- "
-!
-
-symSpaceUsed
- "return the number of bytes allocated for old objects in sym space."
-
-%{ /* NOCONTEXT */
- extern unsigned __symSpaceUsed();
-
- RETURN ( _MKSMALLINT(__symSpaceUsed()) );
-%}
- "
- ObjectMemory symSpaceUsed
- "
-!
-
-fixSpaceUsed
- "return the number of bytes allocated for old objects in fix space."
-
-%{ /* NOCONTEXT */
- extern unsigned __fixSpaceUsed();
-
- RETURN ( _MKSMALLINT(__fixSpaceUsed()) );
-%}
- "
- ObjectMemory fixSpaceUsed
- "
-!
-
-freeSpace
- "return the number of bytes in the compact free area.
- (oldSpaceUsed + freeSpaceSize = oldSpaceSize)"
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceSize(), __oldSpaceUsed();
-
- RETURN ( _MKSMALLINT(__oldSpaceSize() - __oldSpaceUsed()) );
-%}
- "
- ObjectMemory freeSpace
- "
-!
-
-freeListSpace
- "return the number of bytes in the free lists.
- (which is included in oldSpaceUsed)"
-
-%{ /* NOCONTEXT */
- extern unsigned __freeListSpace();
-
- RETURN ( _MKSMALLINT(__freeListSpace()) );
-%}
- "
- ObjectMemory freeListSpace
- "
-!
-
-bytesUsed
- "return the number of bytes allocated for objects -
- this number is not exact, since some objects may already be dead
- (i.e. not yet reclaimed by the garbage collector).
- If you need the exact number, you have to loop over all
- objects and ask for the bytesize using ObjectMemory>>sizeOf:."
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceUsed(), __newSpaceUsed(), __freeListSpace();
-
- RETURN ( _MKSMALLINT(__oldSpaceUsed() + __newSpaceUsed() - __freeListSpace()) );
-%}
- "
- ObjectMemory bytesUsed
- "
-!
-
-oldSpaceAllocatedSinceLastGC
- "return the number of bytes allocated for old objects since the
- last oldspace garbage collect occured. This information is used
- by ProcessorScheduler to decide when to start the incremental
- background GC."
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceAllocatedSinceLastGC();
-
- RETURN ( _MKSMALLINT(__oldSpaceAllocatedSinceLastGC()) );
-%}
- "
- ObjectMemory oldSpaceAllocatedSinceLastGC
- "
-!
-
-tenureAge
- "return the current tenure age - thats the number of times
- an object has to survive scavenges to be moved into oldSpace.
- For statistic/debugging only - this method may vanish"
-
-%{ /* NOCONTEXT */
- extern unsigned __tenureAge();
-
- RETURN ( _MKSMALLINT(__tenureAge()) );
-%}
-!
-
-lastScavengeReclamation
- "returns the number of bytes replacimed by the last scavenge.
- For statistic only - this may vanish."
-
-%{ /* NOCONTEXT */
- extern int __newSpaceReclaimed();
-
- RETURN ( _MKSMALLINT(__newSpaceReclaimed()) );
-%}
- "percentage of reclaimed objects is returned by:
-
- ((ObjectMemory lastScavengeReclamation)
- / (ObjectMemory newSpaceSize)) * 100.0
- "
-!
-
-resetMinScavengeReclamation
- "resets the number of bytes replacimed by the least effective scavenge.
- For statistic only - this may vanish."
-
-%{ /* NOCONTEXT */
- extern int __resetNewSpaceReclaimedMin();
-
- __resetNewSpaceReclaimedMin();
-%}.
- ^ self
- "
- ObjectMemory resetMinScavengeReclamation.
- ObjectMemory minScavengeReclamation
- "
-!
-
-minScavengeReclamation
- "returns the number of bytes replacimed by the least effective scavenge.
- For statistic only - this may vanish."
-
-%{ /* NOCONTEXT */
- extern int __newSpaceReclaimedMin();
-
- RETURN ( _MKSMALLINT(__newSpaceReclaimedMin()) );
-%}
- "
- ObjectMemory minScavengeReclamation
- "
-!
-
-runsSingleOldSpace
- "return true, if the system runs in a single oldSpace or
- false if not.
- The memory system will always drop the second semispace when
- running out of virtual memory, or the baker-limit is reached.
- OBSOLETE:
- the system may now decide at any time to switch between
- single and double-space algorithms, depending on the overall memory
- size. You will now almost always get false as result, since the
- second semispace is only allocated when needed, and released
- immediately afterwards.
- "
-
-%{ /* NOCONTEXT */
- extern int __runsSingleOldSpace();
-
- RETURN ( (__runsSingleOldSpace() ? true : false) );
-%}
- "
- ObjectMemory runsSingleOldSpace
- "
-!
-
-incrementalGCPhase
- "returns the internal state of the incremental GC.
- The meaning of those numbers is a secret :-).
- (for the curious: (currently)
- 2 is idle, 3..11 are various mark phases,
- 12 is the sweep phase. 0 and 1 are cleanup phases when the
- incr. GC gets interrupted by a full GC).
- Do not depend on the values - there may be additional phases in
- future versions (incremental compact ;-).
- This is for debugging and monitoring only - and may change or vanish"
-
-%{ /* NOCONTEXT */
- extern int __incrGCphase();
-
- RETURN (_MKSMALLINT(__incrGCphase()));
-%}
-!
-
-scavengeCount
- "return the number of scavenges that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __scavengeCount();
-
- RETURN (_MKSMALLINT(__scavengeCount()));
-%}
- "
- ObjectMemory scavengeCount
- "
-!
-
-markAndSweepCount
- "return the number of mark&sweep collects that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __markAndSweepCount();
-
- RETURN (_MKSMALLINT(__markAndSweepCount()));
-%}
- "
- ObjectMemory markAndSweepCount
- "
-!
-
-garbageCollectCount
- "return the number of compressing collects that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __garbageCollectCount();
-
- RETURN (_MKSMALLINT(__garbageCollectCount()));
-%}
- "
- ObjectMemory garbageCollectCount
- "
-!
-
-incrementalGCCount
- "return the number of incremental collects that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __incrementalGCCount();
-
- RETURN (_MKSMALLINT(__incrementalGCCount()));
-%}
- "
- ObjectMemory incrementalGCCount
- "
-!
-
-rememberedSetSize
- "return the number of old objects referencing new ones.
- This is a VM debugging interface and may vanish without notice."
-
-%{ /* NOCONTEXT */
- extern int __rememberedSetSize();
-
- RETURN (_MKSMALLINT(__rememberedSetSize()));
-%}
- "
- ObjectMemory rememberedSetSize
- "
-!
-
-lifoRememberedSetSize
- "return the size of the lifoRemSet.
- This is a VM debugging interface and may vanish without notice."
-
-%{ /* NOCONTEXT */
- extern int __lifoRememberedSetSize();
-
- RETURN (_MKSMALLINT(__lifoRememberedSetSize()));
-%}
- "
- ObjectMemory lifoRememberedSetSize
- "
-!
-
-lifoRememberedSet
- "return the lifoRemSet.
- This is pure VM debugging and will vanish without notice."
-
-%{ /* NOCONTEXT */
- extern OBJ __lifoRememberedSet();
-
- RETURN ( __lifoRememberedSet() );
-%}
- "
- ObjectMemory lifoRememberedSet
- "
-!
-
-numberOfWeakObjects
- "return the number of weak objects in the system"
-
-%{ /* NOCONTEXT */
- extern int __weakListSize();
-
- RETURN ( __MKSMALLINT(__weakListSize()) );
-%}
- "
- ObjectMemory numberOfWeakObjects
- "
-!
-
-numberOfObjects
- "return the number of objects in the system."
-
- |tally "{ Class: SmallInteger }"|
-
- tally := 0.
- self allObjectsDo:[:obj | tally := tally + 1].
- ^ tally
-
- "
- ObjectMemory numberOfObjects
- "
-!
-
-collectObjectsWhich:aBlock
- "helper for the whoReferences queries. Returns a collection
- of objects for which aBlock returns true."
-
- |aCollection|
-
- aCollection := IdentitySet new.
- self allObjectsDo:[:o |
- (aBlock value:o) ifTrue:[
- aCollection add:o
- ]
- ].
- (aCollection size == 0) ifTrue:[
- "actually this cannot happen - there is always one"
- ^ nil
- ].
- ^ aCollection
-!
-
-whoReferences:anObject
- "return a collection of objects referencing the argument, anObject"
-
- ^ self collectObjectsWhich:[:o | o references:anObject]
-
- "
- (ObjectMemory whoReferences:Transcript) printNL
- "
-!
-
-whoReferencesInstancesOf:aClass
- "return a collection of objects refering to instances
- of the argument, aClass"
-
- ^ self collectObjectsWhich:[:o | o referencesInstanceOf:aClass]
-
- "
- (ObjectMemory whoReferencesInstancesOf:SystemBrowser) printNL
- "
-!
-
-whoReferencesDerivedInstancesOf:aClass
- "return a collection of objects refering to instances
- of the argument, aClass or a subclass of it."
-
- ^ self collectObjectsWhich:[:o | o referencesDerivedInstanceOf:aClass]
-
- "
- (ObjectMemory whoReferencesDerivedInstancesOf:View) printNL
- "
-!
-
-maximumIdentityHashValue
- "for ST-80 compatibility: return the maximum value
- a hashKey as returned by identityHash can get.
- Since ST/X uses direct pointers, a field in the objectHeader
- is used, which is currently 11 bits in size."
-
-%{ /* NOCONTEXT */
- RETURN ( __MKSMALLINT( __MAX_HASH__ << __HASH_SHIFT__) );
-%}
- "
- ObjectMemory maximumIdentityHashValue
- "
-! !
-
-!ObjectMemory class methodsFor:'debug queries'!
-
-printReferences:anObject
- "for debugging: print referents to anObject.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice
- use ObjectMemory>>whoReferences: or anObject>>allOwners."
-
-%{
- __printRefChain(__context, anObject);
-%}
-!
-
-dumpObject:someObject
- "low level dump an object.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{
- dumpObject(someObject);
-%}
- "
- ObjectMemory dumpObject:true
- ObjectMemory dumpObject:(Array new:10)
- ObjectMemory dumpObject:(10@20 corner:30@40)
- "
-!
-
-addressOf:anObject
- "return the core address of anObject as an integer
- - since objects may move around, the returned value is invalid after the
- next scavenge/collect.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* NOCONTEXT */
-
- if (! __isNonNilObject(anObject)) {
- RETURN ( nil );
- }
- if (((int)anObject >= _MIN_INT) && ((int)anObject <= _MAX_INT)) {
- RETURN ( _MKSMALLINT((int)anObject) );
- }
- RETURN ( _MKLARGEINT((int)anObject) );
-%}
- "
- |p|
- p := Point new.
- ((ObjectMemory addressOf:p) printStringRadix:16) printNL.
- ObjectMemory scavenge.
- ((ObjectMemory addressOf:p) printStringRadix:16) printNL.
- "
-!
-
-objectAt:anAddress
- "return whatever anAddress points to as object.
- BIG BIG DANGER ALERT:
- this method is only to be used for debugging ST/X itself
- - you can easily (and badly) crash the system.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
- |low high|
-
- low := anAddress bitAnd:16rFFFF.
- high := (anAddress bitShift:16) bitAnd:16rFFFF.
-%{
- if (__bothSmallInteger(low, high)) {
- RETURN ((OBJ)((_intVal(high) << 16) | _intVal(low)));
- }
-%}
-!
-
-sizeOf:anObject
- "return the size of anObject in bytes.
- (this is not the same as 'anObject size').
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* NOCONTEXT */
-
- RETURN ( __isNonNilObject(anObject) ? _MKSMALLINT(__qSize(anObject)) : _MKSMALLINT(0) )
-%}
- "
- |hist big nw|
-
- hist := Array new:100 withAll:0.
- big := 0.
- ObjectMemory allObjectsDo:[:o |
- nw := (ObjectMemory sizeOf:o) // 4 + 1.
- nw > 100 ifTrue:[
- big := big + 1
- ] ifFalse:[
- hist at:nw put:(hist at:nw) + 1
- ].
- ].
- hist printNL.
- big printNL
- "
-!
-
-ageOf:anObject
- "return the number of scavenges, an object has survived
- in new space.
- For old objects and living contexts, the returned number is invalid.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* NOCONTEXT */
-
- if (! __isNonNilObject(anObject)) {
- RETURN ( 0 );
- }
- RETURN ( _MKSMALLINT( _GET_AGE(anObject) ) );
-%}
- "
- |p|
- p := Point new.
- (ObjectMemory ageOf:p) printNL.
- ObjectMemory tenuringScavenge.
- (ObjectMemory spaceOf:p) printNL.
- ObjectMemory tenuringScavenge.
- (ObjectMemory spaceOf:p) printNL.
- ObjectMemory tenuringScavenge.
- (ObjectMemory spaceOf:p) printNL.
- ObjectMemory tenuringScavenge.
- (ObjectMemory spaceOf:p) printNL.
- "
-!
-
-flagsOf:anObject
- "For debugging only.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* NOCONTEXT */
-
- if (! __isNonNilObject(anObject)) {
- RETURN ( nil );
- }
- RETURN ( _MKSMALLINT( anObject->o_flags ) );
-%}
- "
-F_ISREMEMBERED 1 /* a new-space thing being refd by some oldSpace thing */
-F_ISFORWARDED 2 /* a forwarded object (you will never see this here) */
-F_DEREFERENCED 4 /* a collection after grow (not currently used) */
-F_ISONLIFOLIST 8 /* a non-lifo-context-referencing-obj already on list */
-F_MARK 16 /* mark bit for background collector */
- "
-
- "
- |arr|
-
- arr := Array new.
- arr at:1 put:([thisContext] value).
- (ObjectMemory flagsOf:anObject) printNL
- "
-!
-
-spaceOf:anObject
- "return the memory space, in which anObject is.
- - since objects may move between spaces,
- the returned value may be invalid after the next scavenge/collect.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* NOCONTEXT */
-
- if (! __isNonNilObject(anObject)) {
- RETURN ( nil );
- }
- RETURN ( _MKSMALLINT( __qSpace(anObject) ) );
-%}
-! !
-
-!ObjectMemory class methodsFor:'garbage collection'!
-
-scavenge
- "collect young objects, without aging (i.e. no tenure).
- Can be used to quickly get rid of shortly before allocated
- stuff. This is relatively fast (compared to oldspace collect).
-
- An example where a non-tenuring scavenge makes sense is when
- allocating some OperatingSystem resource (a Color, File or View)
- and the OS runs out of resources. In this case, the scavenge may
- free some ST-objects and therefore (by signalling the WeakArrays
- or Registries) free the OS resources too.
- Of course, only recently allocated resources will be freed this
- way. If none was freed, a full collect will be needed."
-%{
- __nonTenuringScavenge(__context);
-%}
-
- "
- ObjectMemory scavenge
- "
-!
-
-tenuringScavenge
- "collect newspace stuff, with aging (i.e. objects old enough
- will be moved into the oldSpace).
- Use this for debugging and testing only - the system performs
- this automatically when the newspace fills up.
- This is relatively fast (compared to oldspace collect)"
-%{
- __scavenge(__context);
-%}
-
- "
- ObjectMemory tenuringScavenge
- "
-!
-
-tenure
- "force all living new stuff into old-space - effectively making
- all living young objects become old objects immediately.
- This is relatively fast (compared to oldspace collect).
-
- This method should only be used in very special situations:
- for example, when building up some long-living data structure
- in a time critical application.
- To do so, you have to do a scavenge followed by a tenure after the
- objects are created. Be careful, to not reference any other chunk-
- data when calling for a tenure (this will lead to lots of garbage in
- the oldspace).
- In normal situations, explicit tenures are not needed."
-%{
- __tenure(__context);
-%}
-
- "
- ObjectMemory tenure
- "
- "
- ... build up long living objects ...
- ObjectMemory scavenge.
- ObjectMemory tenure
- ... continue - objects created above are now in oldSpace ...
- "
-!
-
-garbageCollect
- "search for and free garbage in the oldSpace.
- This can take a long time - especially, if paging is involved."
-
- "/ used to be
- "/ self compressingGarbageCollect
- "/ here; changed to default to markAndSweep
-
- self markAndSweep
-
- "
- ObjectMemory garbageCollect
+ ObjectMemory backgroundCollectorRunning
"
!
@@ -1859,32 +1132,18 @@
"
!
-markAndSweep
- "mark/sweep garbage collector.
- perform a full mark&sweep collect.
- Warning: this may take some time and it is NOT interruptable.
- If you want to do a collect from a background process, or have
- other things to do, better use #incrementalGC which is interruptable."
-%{
- __markAndSweep(__context);
-%}
+garbageCollect
+ "search for and free garbage in the oldSpace.
+ This can take a long time - especially, if paging is involved."
+
+ "/ used to be
+ "/ self compressingGarbageCollect
+ "/ here; changed to default to markAndSweep
+
+ self markAndSweep
"
- ObjectMemory markAndSweep
- "
-!
-
-reclaimSymbols
- "reclaim unused symbols;
- Unused symbols are (currently) not reclaimed automatically,
- but only upon request with this method.
- It takes some time to do this ... and it is NOT interruptable.
- Future versions may do this automatically, while garbage collecting."
-%{
- __reclaimSymbols(__context);
-%}
- "
- ObjectMemory reclaimSymbols
+ ObjectMemory garbageCollect
"
!
@@ -1901,6 +1160,42 @@
%}
!
+gcStepIfUseful
+ "If either the IncrementalGCLimit or the FreeSpaceGCLimits have been
+ reached, perform one incremental garbage collect step.
+ Return true, if more gcSteps are required to finish the cycle,
+ false if done with a gc round.
+ If no limit has been reached yet, do nothing and return false.
+ This is called by the ProcessorScheduler at idle times or by the
+ backgroundCollector."
+
+ |done limit|
+
+ Object abortSignal handle:[:ex |
+ "/ in case of abort (from the debugger),
+ "/ disable gcSteps.
+ done := true.
+ IncrementalGCLimit := FreeSpaceGCLimit := nil.
+ 'OBJMEM: IGC aborted; turning off incremental GC' errorPrintNL
+ ] do:[
+ limit := IncrementalGCLimit.
+ (limit notNil and:[self oldSpaceAllocatedSinceLastGC > limit]) ifTrue:[
+ done := ObjectMemory gcStep
+ ] ifFalse:[
+ limit := FreeSpaceGCLimit.
+ (limit notNil and:[(self freeSpace + self freeListSpace) < limit]) ifTrue:[
+ done := ObjectMemory gcStep.
+ done ifTrue:[
+ self moreOldSpaceIfUseful
+ ].
+ ] ifFalse:[
+ done := true
+ ]
+ ].
+ ].
+ ^ done not
+!
+
incrementalGC
"perform one round of incremental GC steps.
The overall effect of this method is (almost) the same as calling
@@ -1937,70 +1232,53 @@
"
!
-gcStepIfUseful
- "If either the IncrementalGCLimit or the FreeSpaceGCLimits have been
- reached, perform one incremental garbage collect step.
- Return true, if more gcSteps are required to finish the cycle,
- false if done with a gc round.
- If no limit has been reached yet, do nothing and return false.
- This is called by the ProcessorScheduler at idle times or by the
- backgroundCollector."
-
- |done limit|
-
- Object abortSignal handle:[:ex |
- "/ in case of abort (from the debugger),
- "/ disable gcSteps.
- done := true.
- IncrementalGCLimit := FreeSpaceGCLimit := nil.
- 'OBJMEM: IGC aborted; turning off incremental GC' errorPrintNL
- ] do:[
- limit := IncrementalGCLimit.
- (limit notNil and:[self oldSpaceAllocatedSinceLastGC > limit]) ifTrue:[
- done := ObjectMemory gcStep
- ] ifFalse:[
- limit := FreeSpaceGCLimit.
- (limit notNil and:[(self freeSpace + self freeListSpace) < limit]) ifTrue:[
- done := ObjectMemory gcStep.
- done ifTrue:[
- self moreOldSpaceIfUseful
- ].
- ] ifFalse:[
- done := true
- ]
- ].
- ].
- ^ done not
-!
-
-verboseGarbageCollect
- "perform a compressing garbage collect and show some informational
- output on the Transcript"
-
- |nBytesBefore nReclaimed value unit|
-
- nBytesBefore := self oldSpaceUsed.
- self compressingGarbageCollect.
- nReclaimed := nBytesBefore - self oldSpaceUsed.
- nReclaimed > 0 ifTrue:[
- nReclaimed > 1024 ifTrue:[
- nReclaimed > (1024 * 1024) ifTrue:[
- value := nReclaimed // (1024 * 1024).
- unit := ' Mb.'
- ] ifFalse:[
- value := nReclaimed // 1024.
- unit := ' Kb.'
- ]
- ] ifFalse:[
- value := nReclaimed.
- unit := ' bytes.'
- ].
- Transcript show:'reclaimed '; show:value printString.
- Transcript showCr:unit
- ]
+markAndSweep
+ "mark/sweep garbage collector.
+ perform a full mark&sweep collect.
+ Warning: this may take some time and it is NOT interruptable.
+ If you want to do a collect from a background process, or have
+ other things to do, better use #incrementalGC which is interruptable."
+%{
+ __markAndSweep(__context);
+%}
"
- ObjectMemory verboseGarbageCollect
+ ObjectMemory markAndSweep
+ "
+!
+
+reclaimSymbols
+ "reclaim unused symbols;
+ Unused symbols are (currently) not reclaimed automatically,
+ but only upon request with this method.
+ It takes some time to do this ... and it is NOT interruptable.
+ Future versions may do this automatically, while garbage collecting."
+%{
+ __reclaimSymbols(__context);
+%}
+ "
+ ObjectMemory reclaimSymbols
+ "
+!
+
+scavenge
+ "collect young objects, without aging (i.e. no tenure).
+ Can be used to quickly get rid of shortly before allocated
+ stuff. This is relatively fast (compared to oldspace collect).
+
+ An example where a non-tenuring scavenge makes sense is when
+ allocating some OperatingSystem resource (a Color, File or View)
+ and the OS runs out of resources. In this case, the scavenge may
+ free some ST-objects and therefore (by signalling the WeakArrays
+ or Registries) free the OS resources too.
+ Of course, only recently allocated resources will be freed this
+ way. If none was freed, a full collect will be needed."
+%{
+ __nonTenuringScavenge(__context);
+%}
+
+ "
+ ObjectMemory scavenge
"
!
@@ -2074,170 +1352,100 @@
"
!
-backgroundCollectorRunning
- "return true, if a backgroundCollector is running"
-
- ^ BackgroundCollectProcess notNil
+tenure
+ "force all living new stuff into old-space - effectively making
+ all living young objects become old objects immediately.
+ This is relatively fast (compared to oldspace collect).
+
+ This method should only be used in very special situations:
+ for example, when building up some long-living data structure
+ in a time critical application.
+ To do so, you have to do a scavenge followed by a tenure after the
+ objects are created. Be careful, to not reference any other chunk-
+ data when calling for a tenure (this will lead to lots of garbage in
+ the oldspace).
+ In normal situations, explicit tenures are not needed."
+%{
+ __tenure(__context);
+%}
"
- ObjectMemory backgroundCollectorRunning
+ ObjectMemory tenure
+ "
+ "
+ ... build up long living objects ...
+ ObjectMemory scavenge.
+ ObjectMemory tenure
+ ... continue - objects created above are now in oldSpace ...
+ "
+!
+
+tenuringScavenge
+ "collect newspace stuff, with aging (i.e. objects old enough
+ will be moved into the oldSpace).
+ Use this for debugging and testing only - the system performs
+ this automatically when the newspace fills up.
+ This is relatively fast (compared to oldspace collect)"
+%{
+ __scavenge(__context);
+%}
+
+ "
+ ObjectMemory tenuringScavenge
+ "
+!
+
+verboseGarbageCollect
+ "perform a compressing garbage collect and show some informational
+ output on the Transcript"
+
+ |nBytesBefore nReclaimed value unit|
+
+ nBytesBefore := self oldSpaceUsed.
+ self compressingGarbageCollect.
+ nReclaimed := nBytesBefore - self oldSpaceUsed.
+ nReclaimed > 0 ifTrue:[
+ nReclaimed > 1024 ifTrue:[
+ nReclaimed > (1024 * 1024) ifTrue:[
+ value := nReclaimed // (1024 * 1024).
+ unit := ' Mb.'
+ ] ifFalse:[
+ value := nReclaimed // 1024.
+ unit := ' Kb.'
+ ]
+ ] ifFalse:[
+ value := nReclaimed.
+ unit := ' bytes.'
+ ].
+ Transcript show:'reclaimed '; show:value printString.
+ Transcript showCr:unit
+ ]
+
+ "
+ ObjectMemory verboseGarbageCollect
"
! !
!ObjectMemory class methodsFor:'garbage collector control'!
-freeSpaceGCLimit:aNumber
- "set the freeSpace limit for incremental GC activation.
- The system will start doing incremental background GC, once less than this number
- of bytes are available for allocation.
- The default is nil; setting it to nil will turn this trigger off."
-
- FreeSpaceGCLimit := aNumber
-
- "
- the following will start the incrementalGC (in the background)
- whenever the freeSpace drops below 1meg of free space
- "
- "
- ObjectMemory freeSpaceGCLimit:1000000.
- "
-
- "
- turn it off (i.e. let the system hit the wall ...)
- "
- "
- ObjectMemory freeSpaceGCLimit:nil.
- "
-!
-
-freeSpaceGCAmount:aNumber
- "set the amount to be allocated if, after an incrementalGC,
- not at least FreeSpaceGCLimit bytes are available for allocation.
- The amount should be greater than the limit, otherwise the incremental
- GC may try over and over to get the memory (actually waisting time)."
-
- FreeSpaceGCAmount := aNumber
-
- "
- the following will try to always keep at least 1meg of free space
- (in the background) and start to do so, whenever the freeSpace drops
- below 250k.
- "
- "
- ObjectMemory freeSpaceGCLimit:250000.
- ObjectMemory freeSpaceGCAmount:1000000.
- "
-
- "
- turn it off (i.e. let the system compute an appropriate amount ...)
- "
- "
- ObjectMemory freeSpaceGCAmount:nil.
- "
-!
-
-freeSpaceGCLimit
- "return the freeSpace limit for incremental GC activation.
- The system will start doing incremental background GC, once less than this number
- of bytes are available in the compact free space.
- The default is 100000; setting it to nil will turn this trigger off."
-
- ^ FreeSpaceGCLimit
-
- "
- ObjectMemory freeSpaceGCLimit
- "
-!
-
-freeSpaceGCAmount
- "return the amount to be allocated if, after an incrementalGC,
- not at least FreeSpaceGCLimit bytes are available for allocation.
- The default is nil, which lets the system compute an abbpropriate value"
-
- ^ FreeSpaceGCAmount
+announceOldSpaceNeed:howMuch
+ "announce to the memory system, that howMuch bytes of memory will be needed
+ soon, which is going to live longer (whatever that means).
+ It first checks if the memory can be allocated without forcing a compressing
+ GC. If not, the oldSpace is increased. This may also lead to a slow compressing
+ collect. However, many smaller increases are avoided afterwards. Calling this
+ method before allocating huge chunks of data may provide better overall performance.
+ Notice: this is a nonstandard interface - use only in special situations."
+
+ (self checkForFastNew:howMuch) ifFalse:[
+ self incrementalGC.
+ (self checkForFastNew:howMuch) ifFalse:[
+ self moreOldSpace:howMuch
+ ]
+ ]
"
- ObjectMemory freeSpaceGCAmount
- "
-!
-
-incrementalGCLimit:aNumber
- "set the allocatedSinceLastGC limit for incremental GC activation.
- The system will start doing incremental background GC, once more than this number
- of bytes have been allocated since the last GC.
- The default is 500000; setting it to nil will turn this trigger off."
-
- IncrementalGCLimit := aNumber
-
- "
- ObjectMemory incrementalGCLimit:500000. 'do incr. GC very seldom'
- ObjectMemory incrementalGCLimit:100000. 'medium'
- ObjectMemory incrementalGCLimit:10000. 'do incr. GC very often'
- ObjectMemory incrementalGCLimit:nil. 'never'
- "
-!
-
-incrementalGCLimit
- "return the allocatedSinceLastGC limit for incremental GC activation.
- The system will start doing incremental background GC, once more than this number
- of bytes have been allocated since the last GC.
- The default is 500000; setting it to nil will turn this trigger off."
-
- ^ IncrementalGCLimit
-
- "
- ObjectMemory incrementalGCLimit
- "
-!
-
-moreOldSpaceIfUseful
- "to be called after an incremental GC cycle;
- if freeSpace is still below limit, allocate more oldSpace"
-
- |limit free amount|
-
- limit := FreeSpaceGCLimit.
- limit notNil ifTrue:[
- "/ if reclaimed space is below limit, we have to allocate more
- "/ oldSpace, to avoid excessive gcSteps (due to freeSpaceLimit
- "/ still not reached)
- "/
- free := self freeSpace + self freeListSpace.
- free < (limit * 3 // 2) ifTrue:[
- amount := FreeSpaceGCAmount.
- amount isNil ifTrue:[
- amount := limit * 3 // 2.
- ].
- 'OBJECTMEMORY: moreOldSpace to satisfy free-limit' infoPrintNL.
- (self moreOldSpace:(amount - free + (64*1024))) ifFalse:[
- "/
- "/ could not increase oldspace; reset FreeSpaceGCLimit to avoid
- "/ useless retries
- 'OBJECTMEMORY: could not increase oldSpace - reset limit' errorPrintNL.
- FreeSpaceGCLimit := nil
- ]
- ].
- ].
-!
-
-moreOldSpace:howMuch
- "allocate howMuch bytes more for old objects; return true if this worked,
- false if that failed.
- This is done automatically, when running out of space, but makes
- sense, if its known in advance that a lot of memory is needed to
- avoid multiple reallocations and compresses.
- On systems which do not support the mmap (or equivalent) system call,
- this (currently) implies a compressing garbage collect - so its slow.
- Notice: this is a nonstandard interface - use only in special situations."
-
-%{
- if (__isSmallInteger(howMuch)) {
- RETURN( __moreOldSpace(__context, _intVal(howMuch)) ? true : false );
- }
- RETURN (false);
-%}
- "
- ObjectMemory moreOldSpace:1000000
+ ObjectMemory announceOldSpaceNeed:1000000
"
!
@@ -2268,85 +1476,50 @@
"
!
-announceOldSpaceNeed:howMuch
- "announce to the memory system, that howMuch bytes of memory will be needed
- soon, which is going to live longer (whatever that means).
- It first checks if the memory can be allocated without forcing a compressing
- GC. If not, the oldSpace is increased. This may also lead to a slow compressing
- collect. However, many smaller increases are avoided afterwards. Calling this
- method before allocating huge chunks of data may provide better overall performance.
- Notice: this is a nonstandard interface - use only in special situations."
-
- (self checkForFastNew:howMuch) ifFalse:[
- self incrementalGC.
- (self checkForFastNew:howMuch) ifFalse:[
- self moreOldSpace:howMuch
- ]
- ]
-
- "
- ObjectMemory announceOldSpaceNeed:1000000
- "
-!
-
-oldSpaceIncrement
- "return the oldSpaceIncrement value. Thats the amount by which
- more memory is allocated in case the oldSpace gets filled up.
- In normal situations, the default value used in the VM is fine
- and there is no need to change it."
+avoidTenure:flag
+ "set/clear the avoidTenure flag. If set, aging of newSpace is turned off
+ as long as the newSpace fill-grade stays below some magic high-water mark.
+ If off (the default), aging is done as usual.
+ If the flag is turned on, scavenge may be a bit slower, due to more
+ objects being copied around. However, chances are high that in an idle
+ or (almost idle) system, less objects are moved into oldSpace.
+ Therefore, this helps to avoid oldSpace colelcts, in systems which go into
+ some standby mode and are reactivated by some external event.
+ (the avoid-flag should be turned off there, and set again once the idle loop
+ is reentered).
+
+ This is an EXPERIMENTAL interface."
%{ /* NOCONTEXT */
- extern unsigned __oldSpaceIncrement();
-
- RETURN (_MKSMALLINT( __oldSpaceIncrement(-1) ));
+ __avoidTenure(flag == true ? 1 : 0);
%}
- "
- ObjectMemory oldSpaceIncrement
- "
!
-oldSpaceIncrement:amount
- "set the oldSpaceIncrement value. Thats the amount by which
- more memory is allocated in case the oldSpace gets filled up.
- In normal situations, the default value used in the VM is fine
- and there is no need to change it. This method returns the
- previous increment value."
+checkForFastNew:amount
+ "this method returns true, if amount bytes could be allocated
+ quickly (i.e. without forcing a full GC or compress).
+ This can be used for smart background processes, which want to
+ allocate big chunks of data without disturbing foreground processes
+ too much. Such a process would check for fast-allocation, and perform
+ incremental GC-steps if required. Thus, avoiding the long blocking pause
+ due to a forced (non-incremental) GC.
+ Especially: doing so will not block higher priority foreground processes.
+ See an example use in Behavior>>niceBasicNew:.
+ This is experimental and not guaranteed to be in future versions."
%{ /* NOCONTEXT */
- extern unsigned __oldSpaceIncrement();
+ extern int __checkForFastNew();
if (__isSmallInteger(amount)) {
- RETURN (_MKSMALLINT( __oldSpaceIncrement(_intVal(amount)) ));
+ if (! __checkForFastNew(_intVal(amount))) {
+ RETURN (false);
+ }
}
-%}
- "to change increment to 1Meg:"
- "
- ObjectMemory oldSpaceIncrement:1024*1024
- "
+
+%}.
+ ^ true
!
-oldSpaceCompressLimit:amount
- "set the limit for oldSpace compression. If more memory than this
- limit is in use, the system will not perform compresses on the oldspace,
- but instead do a mark&sweep GC followed by an oldSpace increase if not enough
- could be reclaimed. The default is currently some 8Mb, which is ok for workstations
- with 16..32Mb of physical memory. If your system has much more physical RAM,
- you may want to increase this limit.
- This method returns the previous increment value."
-
-%{ /* NOCONTEXT */
- extern unsigned __compressingGCLimit();
-
- if (__isSmallInteger(amount)) {
- RETURN (_MKSMALLINT( __compressingGCLimit(_intVal(amount)) ));
- }
-%}
- "to change the limit to 12Mb:"
- "
- ObjectMemory oldSpaceCompressLimit:12*1024*1024
- "
-!
-
fastMoreOldSpaceAllocation:aBoolean
"this method turns on/off fastMoreOldSpace allocation.
By default, this is turned off (false), which means that in case of
@@ -2421,80 +1594,108 @@
"
!
-checkForFastNew:amount
- "this method returns true, if amount bytes could be allocated
- quickly (i.e. without forcing a full GC or compress).
- This can be used for smart background processes, which want to
- allocate big chunks of data without disturbing foreground processes
- too much. Such a process would check for fast-allocation, and perform
- incremental GC-steps if required. Thus, avoiding the long blocking pause
- due to a forced (non-incremental) GC.
- Especially: doing so will not block higher priority foreground processes.
- See an example use in Behavior>>niceBasicNew:.
- This is experimental and not guaranteed to be in future versions."
-
-%{ /* NOCONTEXT */
- extern int __checkForFastNew();
-
- if (__isSmallInteger(amount)) {
- if (! __checkForFastNew(_intVal(amount))) {
- RETURN (false);
- }
- }
-
-%}.
- ^ true
+freeSpaceGCAmount
+ "return the amount to be allocated if, after an incrementalGC,
+ not at least FreeSpaceGCLimit bytes are available for allocation.
+ The default is nil, which lets the system compute an abbpropriate value"
+
+ ^ FreeSpaceGCAmount
+
+ "
+ ObjectMemory freeSpaceGCAmount
+ "
+!
+
+freeSpaceGCAmount:aNumber
+ "set the amount to be allocated if, after an incrementalGC,
+ not at least FreeSpaceGCLimit bytes are available for allocation.
+ The amount should be greater than the limit, otherwise the incremental
+ GC may try over and over to get the memory (actually waisting time)."
+
+ FreeSpaceGCAmount := aNumber
+
+ "
+ the following will try to always keep at least 1meg of free space
+ (in the background) and start to do so, whenever the freeSpace drops
+ below 250k.
+ "
+ "
+ ObjectMemory freeSpaceGCLimit:250000.
+ ObjectMemory freeSpaceGCAmount:1000000.
+ "
+
+ "
+ turn it off (i.e. let the system compute an appropriate amount ...)
+ "
+ "
+ ObjectMemory freeSpaceGCAmount:nil.
+ "
+!
+
+freeSpaceGCLimit
+ "return the freeSpace limit for incremental GC activation.
+ The system will start doing incremental background GC, once less than this number
+ of bytes are available in the compact free space.
+ The default is 100000; setting it to nil will turn this trigger off."
+
+ ^ FreeSpaceGCLimit
+
+ "
+ ObjectMemory freeSpaceGCLimit
+ "
!
-turnGarbageCollectorOff
- "turn off the generational garbage collector by forcing new objects to be
- allocated directly in oldSpace (instead of newSpace)
- WARNING:
- This is somewhat dangerous: if collector is turned off,
- and too many objects are created, the system may run into trouble
- (i.e. oldSpace becomes full) and be forced to perform a full mark&sweep
- or even a compressing collect - making the overall realtime behavior worse.
- Use this only for special purposes or when realtime behavior
- is required for a limited time period.
-
- OBSOLETE: this is no longer supported
- - it may be a no-operation by the time you read this."
-
-%{ /* NOCONTEXT */
- __allocForceSpace(OLDSPACE);
-%}
+freeSpaceGCLimit:aNumber
+ "set the freeSpace limit for incremental GC activation.
+ The system will start doing incremental background GC, once less than this number
+ of bytes are available for allocation.
+ The default is nil; setting it to nil will turn this trigger off."
+
+ FreeSpaceGCLimit := aNumber
+
+ "
+ the following will start the incrementalGC (in the background)
+ whenever the freeSpace drops below 1meg of free space
+ "
+ "
+ ObjectMemory freeSpaceGCLimit:1000000.
+ "
+
+ "
+ turn it off (i.e. let the system hit the wall ...)
+ "
+ "
+ ObjectMemory freeSpaceGCLimit:nil.
+ "
!
-turnGarbageCollectorOn
- "turn garbage collector on again (see ObjectMemory>>turnGarbageCollectorOff)"
-
-%{ /* NOCONTEXT */
- __allocForceSpace(9999);
-%}
+incrementalGCLimit
+ "return the allocatedSinceLastGC limit for incremental GC activation.
+ The system will start doing incremental background GC, once more than this number
+ of bytes have been allocated since the last GC.
+ The default is 500000; setting it to nil will turn this trigger off."
+
+ ^ IncrementalGCLimit
+
+ "
+ ObjectMemory incrementalGCLimit
+ "
!
-makeOld:anObject
- "move anObject into oldSpace.
- This method is for internal & debugging purposes only -
- it may vanish. Dont use it."
-%{
- if (__moveToOldSpace(anObject, __context) < 0) {
- RETURN (false);
- }
-%}.
- ^ true
-!
-
-tenureParameters:magic
- "this is pure magic and not for public eyes ...
- This method allows fine tuning the scavenger internals,
- in cooperation to some statistic & test programs.
- It is undocumented, secret and may vanish.
- If you play around here, the system may behave very strange."
-
-%{ /* NOCONTEXT */
- __tenureParams(magic);
-%}.
+incrementalGCLimit:aNumber
+ "set the allocatedSinceLastGC limit for incremental GC activation.
+ The system will start doing incremental background GC, once more than this number
+ of bytes have been allocated since the last GC.
+ The default is 500000; setting it to nil will turn this trigger off."
+
+ IncrementalGCLimit := aNumber
+
+ "
+ ObjectMemory incrementalGCLimit:500000. 'do incr. GC very seldom'
+ ObjectMemory incrementalGCLimit:100000. 'medium'
+ ObjectMemory incrementalGCLimit:10000. 'do incr. GC very often'
+ ObjectMemory incrementalGCLimit:nil. 'never'
+ "
!
lockTenure:flag
@@ -2526,39 +1727,67 @@
%}
!
-avoidTenure:flag
- "set/clear the avoidTenure flag. If set, aging of newSpace is turned off
- as long as the newSpace fill-grade stays below some magic high-water mark.
- If off (the default), aging is done as usual.
- If the flag is turned on, scavenge may be a bit slower, due to more
- objects being copied around. However, chances are high that in an idle
- or (almost idle) system, less objects are moved into oldSpace.
- Therefore, this helps to avoid oldSpace colelcts, in systems which go into
- some standby mode and are reactivated by some external event.
- (the avoid-flag should be turned off there, and set again once the idle loop
- is reentered).
-
- This is an EXPERIMENTAL interface."
-
-%{ /* NOCONTEXT */
- __avoidTenure(flag == true ? 1 : 0);
+makeOld:anObject
+ "move anObject into oldSpace.
+ This method is for internal & debugging purposes only -
+ it may vanish. Dont use it."
+%{
+ if (__moveToOldSpace(anObject, __context) < 0) {
+ RETURN (false);
+ }
+%}.
+ ^ true
+!
+
+moreOldSpace:howMuch
+ "allocate howMuch bytes more for old objects; return true if this worked,
+ false if that failed.
+ This is done automatically, when running out of space, but makes
+ sense, if its known in advance that a lot of memory is needed to
+ avoid multiple reallocations and compresses.
+ On systems which do not support the mmap (or equivalent) system call,
+ this (currently) implies a compressing garbage collect - so its slow.
+ Notice: this is a nonstandard interface - use only in special situations."
+
+%{
+ if (__isSmallInteger(howMuch)) {
+ RETURN( __moreOldSpace(__context, _intVal(howMuch)) ? true : false );
+ }
+ RETURN (false);
%}
+ "
+ ObjectMemory moreOldSpace:1000000
+ "
!
-watchTenure:flag
- "set/clear the tenureWatch. If set, an internalError exception will be raised,
- whenever objects are tenured from newSpace into oldSpace
- (except for an explicit tenure request).
- This can be used to validate that no oldSpace objects are created
- (i.e. the system operates fully in newSpace).
- Be careful, if the avoidTenure flag is not set,
- there will almost always be a tenure sooner or later.
-
- EXPERIMENTAL - no warranty"
-
-%{ /* NOCONTEXT */
- __watchTenure(flag == true ? 1 : 0);
-%}
+moreOldSpaceIfUseful
+ "to be called after an incremental GC cycle;
+ if freeSpace is still below limit, allocate more oldSpace"
+
+ |limit free amount|
+
+ limit := FreeSpaceGCLimit.
+ limit notNil ifTrue:[
+ "/ if reclaimed space is below limit, we have to allocate more
+ "/ oldSpace, to avoid excessive gcSteps (due to freeSpaceLimit
+ "/ still not reached)
+ "/
+ free := self freeSpace + self freeListSpace.
+ free < (limit * 3 // 2) ifTrue:[
+ amount := FreeSpaceGCAmount.
+ amount isNil ifTrue:[
+ amount := limit * 3 // 2.
+ ].
+ 'OBJECTMEMORY: moreOldSpace to satisfy free-limit' infoPrintNL.
+ (self moreOldSpace:(amount - free + (64*1024))) ifFalse:[
+ "/
+ "/ could not increase oldspace; reset FreeSpaceGCLimit to avoid
+ "/ useless retries
+ 'OBJECTMEMORY: could not increase oldSpace - reset limit' errorPrintNL.
+ FreeSpaceGCLimit := nil
+ ]
+ ].
+ ].
!
newSpaceSize:newSize
@@ -2595,15 +1824,386 @@
ObjectMemory newSpaceSize:400*1024
"
+!
+
+oldSpaceCompressLimit:amount
+ "set the limit for oldSpace compression. If more memory than this
+ limit is in use, the system will not perform compresses on the oldspace,
+ but instead do a mark&sweep GC followed by an oldSpace increase if not enough
+ could be reclaimed. The default is currently some 8Mb, which is ok for workstations
+ with 16..32Mb of physical memory. If your system has much more physical RAM,
+ you may want to increase this limit.
+ This method returns the previous increment value."
+
+%{ /* NOCONTEXT */
+ extern unsigned __compressingGCLimit();
+
+ if (__isSmallInteger(amount)) {
+ RETURN (_MKSMALLINT( __compressingGCLimit(_intVal(amount)) ));
+ }
+%}
+ "to change the limit to 12Mb:"
+ "
+ ObjectMemory oldSpaceCompressLimit:12*1024*1024
+ "
+!
+
+oldSpaceIncrement
+ "return the oldSpaceIncrement value. Thats the amount by which
+ more memory is allocated in case the oldSpace gets filled up.
+ In normal situations, the default value used in the VM is fine
+ and there is no need to change it."
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceIncrement();
+
+ RETURN (_MKSMALLINT( __oldSpaceIncrement(-1) ));
+%}
+ "
+ ObjectMemory oldSpaceIncrement
+ "
+!
+
+oldSpaceIncrement:amount
+ "set the oldSpaceIncrement value. Thats the amount by which
+ more memory is allocated in case the oldSpace gets filled up.
+ In normal situations, the default value used in the VM is fine
+ and there is no need to change it. This method returns the
+ previous increment value."
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceIncrement();
+
+ if (__isSmallInteger(amount)) {
+ RETURN (_MKSMALLINT( __oldSpaceIncrement(_intVal(amount)) ));
+ }
+%}
+ "to change increment to 1Meg:"
+ "
+ ObjectMemory oldSpaceIncrement:1024*1024
+ "
+!
+
+tenureParameters:magic
+ "this is pure magic and not for public eyes ...
+ This method allows fine tuning the scavenger internals,
+ in cooperation to some statistic & test programs.
+ It is undocumented, secret and may vanish.
+ If you play around here, the system may behave very strange."
+
+%{ /* NOCONTEXT */
+ __tenureParams(magic);
+%}.
+!
+
+turnGarbageCollectorOff
+ "turn off the generational garbage collector by forcing new objects to be
+ allocated directly in oldSpace (instead of newSpace)
+ WARNING:
+ This is somewhat dangerous: if collector is turned off,
+ and too many objects are created, the system may run into trouble
+ (i.e. oldSpace becomes full) and be forced to perform a full mark&sweep
+ or even a compressing collect - making the overall realtime behavior worse.
+ Use this only for special purposes or when realtime behavior
+ is required for a limited time period.
+
+ OBSOLETE: this is no longer supported
+ - it may be a no-operation by the time you read this."
+
+%{ /* NOCONTEXT */
+ __allocForceSpace(OLDSPACE);
+%}
+!
+
+turnGarbageCollectorOn
+ "turn garbage collector on again (see ObjectMemory>>turnGarbageCollectorOff)"
+
+%{ /* NOCONTEXT */
+ __allocForceSpace(9999);
+%}
+!
+
+watchTenure:flag
+ "set/clear the tenureWatch. If set, an internalError exception will be raised,
+ whenever objects are tenured from newSpace into oldSpace
+ (except for an explicit tenure request).
+ This can be used to validate that no oldSpace objects are created
+ (i.e. the system operates fully in newSpace).
+ Be careful, if the avoidTenure flag is not set,
+ there will almost always be a tenure sooner or later.
+
+ EXPERIMENTAL - no warranty"
+
+%{ /* NOCONTEXT */
+ __watchTenure(flag == true ? 1 : 0);
+%}
! !
-!ObjectMemory class ignoredMethodsFor:'object finalization'!
-
-allShadowObjectsDo:aBlock
- "evaluate the argument, aBlock for all known shadow objects"
-%{
- __allShadowObjectsDo(&aBlock COMMA_CON);
-%}
+!ObjectMemory class methodsFor:'interrupt handler access'!
+
+childSignalInterruptHandler
+ "return the handler for UNIX-death-of-a-childprocess-signal interrupts"
+
+ ^ ChildSignalInterruptHandler
+!
+
+customInterruptHandler
+ "return the handler for custom interrupts"
+
+ ^ CustomInterruptHandler
+!
+
+customInterruptHandler:aHandler
+ "set the handler for custom interrupts"
+
+ CustomInterruptHandler := aHandler
+!
+
+disposeInterruptHandler
+ "return the handler for object disposal interrupts"
+
+ ^ DisposeInterruptHandler
+!
+
+disposeInterruptHandler:aHandler
+ "set the handler for object disposal interrupts"
+
+ DisposeInterruptHandler := aHandler
+!
+
+errorInterruptHandler
+ "return the handler for display error interrupts"
+
+ ^ ErrorInterruptHandler
+!
+
+errorInterruptHandler:aHandler
+ "set the handler for display error interrupts"
+
+ ErrorInterruptHandler := aHandler
+!
+
+exceptionInterruptHandler
+ "return the handler for floating point exception interrupts"
+
+ ^ ExceptionInterruptHandler
+!
+
+internalErrorHandler
+ "return the handler for ST/X internal errors.
+ An internal error is reported for example when a methods
+ bytecode is not a ByteArray, the selector table is not an Array
+ etc.
+ Those should not occur in normal circumstances."
+
+ ^ InternalErrorHandler
+!
+
+ioInterruptHandler
+ "return the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
+
+ ^ IOInterruptHandler
+!
+
+ioInterruptHandler:aHandler
+ "set the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
+
+ IOInterruptHandler := aHandler
+!
+
+recursionInterruptHandler
+ "return the handler for recursion/stack overflow interrupts"
+
+ ^ RecursionInterruptHandler
+!
+
+recursionInterruptHandler:aHandler
+ "set the handler for recursion/stack overflow interrupts"
+
+ RecursionInterruptHandler := aHandler
+!
+
+registerErrorInterruptHandler:aHandler forID:errorIDSymbol
+ "register a handler"
+
+ RegisteredErrorInterruptHandlers isNil ifTrue:[
+ RegisteredErrorInterruptHandlers := IdentityDictionary new
+ ].
+ RegisteredErrorInterruptHandlers at:errorIDSymbol put:aHandler
+!
+
+registeredErrorInterruptHandlers
+ "return registered handlers"
+
+ ^ RegisteredErrorInterruptHandlers
+!
+
+signalInterruptHandler
+ "return the handler for UNIX-signal interrupts"
+
+ ^ SignalInterruptHandler
+!
+
+signalInterruptHandler:aHandler
+ "set the handler for UNIX-signal interrupts"
+
+ SignalInterruptHandler := aHandler
+!
+
+spyInterruptHandler
+ "return the handler for spy-timer interrupts"
+
+ ^ SpyInterruptHandler
+!
+
+spyInterruptHandler:aHandler
+ "set the handler for spy-timer interrupts"
+
+ SpyInterruptHandler := aHandler
+!
+
+stepInterruptHandler
+ "return the handler for single step interrupts"
+
+ ^ StepInterruptHandler
+!
+
+stepInterruptHandler:aHandler
+ "set the handler for single step interrupts"
+
+ StepInterruptHandler := aHandler
+!
+
+timerInterruptHandler
+ "return the handler for timer interrupts"
+
+ ^ TimerInterruptHandler
+!
+
+timerInterruptHandler:aHandler
+ "set the handler for timer interrupts"
+
+ TimerInterruptHandler := aHandler
+!
+
+userInterruptHandler
+ "return the handler for CNTL-C interrupt handling"
+
+ ^ UserInterruptHandler
+!
+
+userInterruptHandler:aHandler
+ "set the handler for CNTL-C interrupt handling"
+
+ UserInterruptHandler := aHandler
+! !
+
+!ObjectMemory class methodsFor:'interrupt statistics'!
+
+interruptLatency:ms receiver:rec class:cls selector:sel vmActivity:vmActivity
+ "example implementation of latencyTime monitoring:
+ This method simply measures the max-latency time.
+ You may want to use some other handler (see #interruptLatencyMonitor:)
+ and extract more information (blocking context).
+ DEMO Example."
+
+ ms > MaxInterruptLatency ifTrue:[
+ MaxInterruptLatency := ms.
+ 'IRQ-LATENCY: ' infoPrint. rec class infoPrint. ' ' infoPrint. sel infoPrint. '(' infoPrint. vmActivity infoPrint . ') ---> ' infoPrint. ms infoPrintNL.
+ ].
+ (InterruptLatencyGoal notNil and:[ms > InterruptLatencyGoal]) ifTrue:[
+ '*** IRQ REALTIME-DEADLINE MISSED: ' errorPrint.
+ rec isBehavior ifTrue:[
+ rec name errorPrint. 'class' errorPrint.
+ ] ifFalse:[
+ rec class errorPrint
+ ].
+ ' ' errorPrint. sel errorPrint. '(' errorPrint. vmActivity errorPrint . ') ---> ' errorPrint.
+ ms errorPrintNL.
+ ].
+
+ "to enable the demo handler:
+
+ ObjectMemory resetMaxInterruptLatency.
+ ObjectMemory interruptLatencyMonitor:ObjectMemory.
+ "
+ "to disable timing statistics:
+
+ ObjectMemory interruptLatencyMonitor:nil.
+ ObjectMemory maxInterruptLatency printNL.
+ "
+
+ "Created: 7.11.1995 / 21:05:50 / cg"
+ "Modified: 7.11.1995 / 21:13:33 / cg"
+!
+
+interruptLatencyGoal:millis
+ "setup to report an error message, whenever a realtime goal could not be
+ met due to blocked interrupts or long primitives or GC activity.
+ An argument of nil clears the check.
+ DEMO Example."
+
+ InterruptLatencyGoal := millis.
+ millis isNil ifTrue:[
+ InterruptLatencyMonitor := nil.
+ ] ifFalse:[
+ MaxInterruptLatency := 0.
+ InterruptLatencyMonitor := self.
+ ]
+
+ "
+ ObjectMemory interruptLatencyGoal:50
+ "
+!
+
+interruptLatencyMonitor
+ "return the interrupt-latency-monitor if any.
+ See comment in #interruptLatencyMonitor:.
+ This is a non-standard debugging/realtime instrumentation entry."
+
+ ^ InterruptLatencyMonitor
+!
+
+interruptLatencyMonitor:aHandler
+ "set the interrupt latency monitor. If non-nil, this one will be sent
+ an interruptLatency: message with the millisecond delay between
+ the interrupt and its handling.
+ This is a non-standard debugging/realtime instrumentation entry."
+
+ InterruptLatencyMonitor := aHandler
+!
+
+maxInterruptLatency
+ "return the maximum accumulated interrupt latency in millis.
+ DEMO Example."
+
+ ^ MaxInterruptLatency
+!
+
+resetMaxInterruptLatency
+ "reset the maximum accumulated interrupt latency probe time.
+ DEMO Example."
+
+ MaxInterruptLatency := 0
+! !
+
+!ObjectMemory class methodsFor:'low memory handling'!
+
+memoryInterrupt
+ "when a low-memory condition arises, ask all classes to
+ remove possibly cached data. You may help the system a bit,
+ in providing a lowSpaceCleanup method in your classes which have
+ lots of data kept somewhere (usually, cached data).
+ - this may or may not help."
+
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass lowSpaceCleanup
+ ].
+
+"/ self error:'almost out of memory'
+ 'almost out of memory' errorPrintNL.
+
+ LowSpaceSemaphore signalIf.
! !
!ObjectMemory class methodsFor:'object finalization'!
@@ -2616,14 +2216,6 @@
%}
!
-finalize
- "tell all weak objects that something happened."
-
- self allChangedShadowObjectsDo:[:aShadowArray |
- aShadowArray lostPointer.
- ]
-!
-
disposeInterrupt
"this is triggered by the garbage collector,
whenever any shadowArray looses a pointer."
@@ -2641,6 +2233,14 @@
]
!
+finalize
+ "tell all weak objects that something happened."
+
+ self allChangedShadowObjectsDo:[:aShadowArray |
+ aShadowArray lostPointer.
+ ]
+!
+
startBackgroundFinalizationAt:aPriority
"start a process doing finalization work in the background.
Can be used to reduce the pauses created by finalization.
@@ -2707,6 +2307,18 @@
!ObjectMemory class methodsFor:'physical memory access'!
+collectedOldSpacePagesDo:aBlock
+ "evaluates aBlock for all pages in the prev. oldSpace, passing
+ the pages address as argument.
+ For internal & debugging use only."
+%{
+ if (__collectedOldSpacePagesDo(&aBlock COMMA_CON) < 0) {
+ RETURN (false);
+ }
+%}.
+ ^ true
+!
+
newSpacePagesDo:aBlock
"evaluates aBlock for all pages in the newSpace, passing
the pages address as argument.
@@ -2731,18 +2343,6 @@
^ true
!
-collectedOldSpacePagesDo:aBlock
- "evaluates aBlock for all pages in the prev. oldSpace, passing
- the pages address as argument.
- For internal & debugging use only."
-%{
- if (__collectedOldSpacePagesDo(&aBlock COMMA_CON) < 0) {
- RETURN (false);
- }
-%}.
- ^ true
-!
-
pageIsInCore:aPageNumber
"return true, if the page (as enumerated via oldSpacePagesDo:)
is in memory; false, if currently paged out. For internal
@@ -2770,6 +2370,472 @@
^ true
! !
+!ObjectMemory class methodsFor:'queries'!
+
+bytesUsed
+ "return the number of bytes allocated for objects -
+ this number is not exact, since some objects may already be dead
+ (i.e. not yet reclaimed by the garbage collector).
+ If you need the exact number, you have to loop over all
+ objects and ask for the bytesize using ObjectMemory>>sizeOf:."
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceUsed(), __newSpaceUsed(), __freeListSpace();
+
+ RETURN ( _MKSMALLINT(__oldSpaceUsed() + __newSpaceUsed() - __freeListSpace()) );
+%}
+ "
+ ObjectMemory bytesUsed
+ "
+!
+
+collectObjectsWhich:aBlock
+ "helper for the whoReferences queries. Returns a collection
+ of objects for which aBlock returns true."
+
+ |aCollection|
+
+ aCollection := IdentitySet new.
+ self allObjectsDo:[:o |
+ (aBlock value:o) ifTrue:[
+ aCollection add:o
+ ]
+ ].
+ (aCollection size == 0) ifTrue:[
+ "actually this cannot happen - there is always one"
+ ^ nil
+ ].
+ ^ aCollection
+!
+
+fixSpaceSize
+ "return the total size of the fix space."
+
+%{ /* NOCONTEXT */
+ extern unsigned __fixSpaceSize();
+
+ RETURN ( _MKSMALLINT(__fixSpaceSize()) );
+%}
+ "
+ ObjectMemory fixSpaceSize
+ "
+!
+
+fixSpaceUsed
+ "return the number of bytes allocated for old objects in fix space."
+
+%{ /* NOCONTEXT */
+ extern unsigned __fixSpaceUsed();
+
+ RETURN ( _MKSMALLINT(__fixSpaceUsed()) );
+%}
+ "
+ ObjectMemory fixSpaceUsed
+ "
+!
+
+freeListSpace
+ "return the number of bytes in the free lists.
+ (which is included in oldSpaceUsed)"
+
+%{ /* NOCONTEXT */
+ extern unsigned __freeListSpace();
+
+ RETURN ( _MKSMALLINT(__freeListSpace()) );
+%}
+ "
+ ObjectMemory freeListSpace
+ "
+!
+
+freeSpace
+ "return the number of bytes in the compact free area.
+ (oldSpaceUsed + freeSpaceSize = oldSpaceSize)"
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceSize(), __oldSpaceUsed();
+
+ RETURN ( _MKSMALLINT(__oldSpaceSize() - __oldSpaceUsed()) );
+%}
+ "
+ ObjectMemory freeSpace
+ "
+!
+
+garbageCollectCount
+ "return the number of compressing collects that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __garbageCollectCount();
+
+ RETURN (_MKSMALLINT(__garbageCollectCount()));
+%}
+ "
+ ObjectMemory garbageCollectCount
+ "
+!
+
+incrementalGCCount
+ "return the number of incremental collects that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __incrementalGCCount();
+
+ RETURN (_MKSMALLINT(__incrementalGCCount()));
+%}
+ "
+ ObjectMemory incrementalGCCount
+ "
+!
+
+incrementalGCPhase
+ "returns the internal state of the incremental GC.
+ The meaning of those numbers is a secret :-).
+ (for the curious: (currently)
+ 2 is idle, 3..11 are various mark phases,
+ 12 is the sweep phase. 0 and 1 are cleanup phases when the
+ incr. GC gets interrupted by a full GC).
+ Do not depend on the values - there may be additional phases in
+ future versions (incremental compact ;-).
+ This is for debugging and monitoring only - and may change or vanish"
+
+%{ /* NOCONTEXT */
+ extern int __incrGCphase();
+
+ RETURN (_MKSMALLINT(__incrGCphase()));
+%}
+!
+
+lastScavengeReclamation
+ "returns the number of bytes replacimed by the last scavenge.
+ For statistic only - this may vanish."
+
+%{ /* NOCONTEXT */
+ extern int __newSpaceReclaimed();
+
+ RETURN ( _MKSMALLINT(__newSpaceReclaimed()) );
+%}
+ "percentage of reclaimed objects is returned by:
+
+ ((ObjectMemory lastScavengeReclamation)
+ / (ObjectMemory newSpaceSize)) * 100.0
+ "
+!
+
+lifoRememberedSet
+ "return the lifoRemSet.
+ This is pure VM debugging and will vanish without notice."
+
+%{ /* NOCONTEXT */
+ extern OBJ __lifoRememberedSet();
+
+ RETURN ( __lifoRememberedSet() );
+%}
+ "
+ ObjectMemory lifoRememberedSet
+ "
+!
+
+lifoRememberedSetSize
+ "return the size of the lifoRemSet.
+ This is a VM debugging interface and may vanish without notice."
+
+%{ /* NOCONTEXT */
+ extern int __lifoRememberedSetSize();
+
+ RETURN (_MKSMALLINT(__lifoRememberedSetSize()));
+%}
+ "
+ ObjectMemory lifoRememberedSetSize
+ "
+!
+
+markAndSweepCount
+ "return the number of mark&sweep collects that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __markAndSweepCount();
+
+ RETURN (_MKSMALLINT(__markAndSweepCount()));
+%}
+ "
+ ObjectMemory markAndSweepCount
+ "
+!
+
+maximumIdentityHashValue
+ "for ST-80 compatibility: return the maximum value
+ a hashKey as returned by identityHash can get.
+ Since ST/X uses direct pointers, a field in the objectHeader
+ is used, which is currently 11 bits in size."
+
+%{ /* NOCONTEXT */
+ RETURN ( __MKSMALLINT( __MAX_HASH__ << __HASH_SHIFT__) );
+%}
+ "
+ ObjectMemory maximumIdentityHashValue
+ "
+!
+
+minScavengeReclamation
+ "returns the number of bytes replacimed by the least effective scavenge.
+ For statistic only - this may vanish."
+
+%{ /* NOCONTEXT */
+ extern int __newSpaceReclaimedMin();
+
+ RETURN ( _MKSMALLINT(__newSpaceReclaimedMin()) );
+%}
+ "
+ ObjectMemory minScavengeReclamation
+ "
+!
+
+newSpaceSize
+ "return the total size of the new space - this is usually fix"
+
+%{ /* NOCONTEXT */
+ extern unsigned __newSpaceSize();
+
+ RETURN ( _MKSMALLINT(__newSpaceSize()) );
+%}
+ "
+ ObjectMemory newSpaceSize
+ "
+!
+
+newSpaceUsed
+ "return the number of bytes allocated for new objects.
+ The returned value is usually obsolete as soon as you do
+ something with it ..."
+
+%{ /* NOCONTEXT */
+ extern unsigned __newSpaceUsed();
+
+ RETURN ( _MKSMALLINT(__newSpaceUsed()) );
+%}
+ "
+ ObjectMemory newSpaceUsed
+ "
+!
+
+numberOfObjects
+ "return the number of objects in the system."
+
+ |tally "{ Class: SmallInteger }"|
+
+ tally := 0.
+ self allObjectsDo:[:obj | tally := tally + 1].
+ ^ tally
+
+ "
+ ObjectMemory numberOfObjects
+ "
+!
+
+numberOfWeakObjects
+ "return the number of weak objects in the system"
+
+%{ /* NOCONTEXT */
+ extern int __weakListSize();
+
+ RETURN ( __MKSMALLINT(__weakListSize()) );
+%}
+ "
+ ObjectMemory numberOfWeakObjects
+ "
+!
+
+oldSpaceAllocatedSinceLastGC
+ "return the number of bytes allocated for old objects since the
+ last oldspace garbage collect occured. This information is used
+ by ProcessorScheduler to decide when to start the incremental
+ background GC."
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceAllocatedSinceLastGC();
+
+ RETURN ( _MKSMALLINT(__oldSpaceAllocatedSinceLastGC()) );
+%}
+ "
+ ObjectMemory oldSpaceAllocatedSinceLastGC
+ "
+!
+
+oldSpaceSize
+ "return the total size of the old space. - may grow slowly"
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceSize();
+
+ RETURN ( _MKSMALLINT(__oldSpaceSize()) );
+%}
+ "
+ ObjectMemory oldSpaceSize
+ "
+!
+
+oldSpaceUsed
+ "return the number of bytes allocated for old objects.
+ (This includes the free lists)"
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceUsed();
+
+ RETURN ( _MKSMALLINT(__oldSpaceUsed()) );
+%}
+ "
+ ObjectMemory oldSpaceUsed
+ "
+!
+
+rememberedSetSize
+ "return the number of old objects referencing new ones.
+ This is a VM debugging interface and may vanish without notice."
+
+%{ /* NOCONTEXT */
+ extern int __rememberedSetSize();
+
+ RETURN (_MKSMALLINT(__rememberedSetSize()));
+%}
+ "
+ ObjectMemory rememberedSetSize
+ "
+!
+
+resetMinScavengeReclamation
+ "resets the number of bytes replacimed by the least effective scavenge.
+ For statistic only - this may vanish."
+
+%{ /* NOCONTEXT */
+ extern int __resetNewSpaceReclaimedMin();
+
+ __resetNewSpaceReclaimedMin();
+%}.
+ ^ self
+ "
+ ObjectMemory resetMinScavengeReclamation.
+ ObjectMemory minScavengeReclamation
+ "
+!
+
+runsSingleOldSpace
+ "return true, if the system runs in a single oldSpace or
+ false if not.
+ The memory system will always drop the second semispace when
+ running out of virtual memory, or the baker-limit is reached.
+ OBSOLETE:
+ the system may now decide at any time to switch between
+ single and double-space algorithms, depending on the overall memory
+ size. You will now almost always get false as result, since the
+ second semispace is only allocated when needed, and released
+ immediately afterwards.
+ "
+
+%{ /* NOCONTEXT */
+ extern int __runsSingleOldSpace();
+
+ RETURN ( (__runsSingleOldSpace() ? true : false) );
+%}
+ "
+ ObjectMemory runsSingleOldSpace
+ "
+!
+
+scavengeCount
+ "return the number of scavenges that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __scavengeCount();
+
+ RETURN (_MKSMALLINT(__scavengeCount()));
+%}
+ "
+ ObjectMemory scavengeCount
+ "
+!
+
+symSpaceSize
+ "return the total size of the sym space."
+
+%{ /* NOCONTEXT */
+ extern unsigned __symSpaceSize();
+
+ RETURN ( _MKSMALLINT(__symSpaceSize()) );
+%}
+ "
+ ObjectMemory symSpaceSize
+ "
+!
+
+symSpaceUsed
+ "return the number of bytes allocated for old objects in sym space."
+
+%{ /* NOCONTEXT */
+ extern unsigned __symSpaceUsed();
+
+ RETURN ( _MKSMALLINT(__symSpaceUsed()) );
+%}
+ "
+ ObjectMemory symSpaceUsed
+ "
+!
+
+tenureAge
+ "return the current tenure age - thats the number of times
+ an object has to survive scavenges to be moved into oldSpace.
+ For statistic/debugging only - this method may vanish"
+
+%{ /* NOCONTEXT */
+ extern unsigned __tenureAge();
+
+ RETURN ( _MKSMALLINT(__tenureAge()) );
+%}
+!
+
+whoReferences:anObject
+ "return a collection of objects referencing the argument, anObject"
+
+ ^ self collectObjectsWhich:[:o | o references:anObject]
+
+ "
+ (ObjectMemory whoReferences:Transcript) printNL
+ "
+!
+
+whoReferencesDerivedInstancesOf:aClass
+ "return a collection of objects refering to instances
+ of the argument, aClass or a subclass of it."
+
+ ^ self collectObjectsWhich:[:o | o referencesDerivedInstanceOf:aClass]
+
+ "
+ (ObjectMemory whoReferencesDerivedInstancesOf:View) printNL
+ "
+!
+
+whoReferencesInstancesOf:aClass
+ "return a collection of objects refering to instances
+ of the argument, aClass"
+
+ ^ self collectObjectsWhich:[:o | o referencesInstanceOf:aClass]
+
+ "
+ (ObjectMemory whoReferencesInstancesOf:SystemBrowser) printNL
+ "
+! !
+
+!ObjectMemory class methodsFor:'semaphore access'!
+
+lowSpaceSemaphore
+ "return the semaphore that is signalled when the system detects a
+ low space condition. Usually, some time after this, an allocationFailure
+ will happen. You can have a cleanup process sitting in that semaphore and
+ start to release object."
+
+ ^ LowSpaceSemaphore
+! !
+
!ObjectMemory class methodsFor:'statistics'!
ageStatistic
@@ -2779,224 +2845,8 @@
%}
! !
-!ObjectMemory class methodsFor:'low memory handling'!
-
-memoryInterrupt
- "when a low-memory condition arises, ask all classes to
- remove possibly cached data. You may help the system a bit,
- in providing a lowSpaceCleanup method in your classes which have
- lots of data kept somewhere (usually, cached data).
- - this may or may not help."
-
- Smalltalk allBehaviorsDo:[:aClass |
- aClass lowSpaceCleanup
- ].
-
-"/ self error:'almost out of memory'
- 'almost out of memory' errorPrintNL.
-
- LowSpaceSemaphore signalIf.
-! !
-
!ObjectMemory class methodsFor:'system management'!
-loadClassBinary:aClassName
- "find the object file for aClassName and -if found - load it;
- this one loads precompiled object files"
-
- |fName newClass|
-
- fName := self fileNameForClass:aClassName.
- fName notNil ifTrue:[
- Class withoutUpdatingChangesDo:
- [
- self loadBinary:(fName , '.o')
- ].
- newClass := self at:(aClassName asSymbol).
- (newClass notNil and:[newClass implements:#initialize]) ifTrue:[
- newClass initialize
- ]
- ]
-!
-
-imageName
- "return the filename of the current image, or nil
- if not running from an image."
-
- ^ ImageName
-
- "
- ObjectMemory imageName
- "
-!
-
-imageBaseName
- "return a reasonable filename to use as baseName (i.e. without extension).
- This is the filename of the current image (without '.img') or,
- if not running from an image, the default name 'st'"
-
- |nm|
-
- nm := ImageName.
- (nm isNil or:[nm isBlank]) ifTrue:[
- ^ 'st'
- ].
- (nm endsWith:'.sav') ifTrue:[
- nm := nm copyWithoutLast:4
- ].
- (nm endsWith:'.img') ifTrue:[
- ^ nm copyWithoutLast:4
- ].
- ^ nm
-
- "
- ObjectMemory imageBaseName
- "
-!
-
-nameForSnapshot
- "return a reasonable filename to store the snapshot image into.
- This is the filename of the current image or,
- if not running from an image, the default name 'st.img'"
-
- ^ self imageBaseName , '.img'
-
- "
- ObjectMemory nameForSnapshot
- "
-!
-
-nameForSources
- "return a reasonable filename to store the sources into.
- This is the basename of the current image with '.img' replaced
- by '.src', or, if not running from an image, the default name 'st.src'"
-
- ^ self imageBaseName , '.src'
-
- "
- ObjectMemory nameForSources
- "
-!
-
-nameForChanges
- "return a reasonable filename to store the changes into.
- Currently, this is defined in a classVariable and defaults to 'changes'.
- In future versions, this will be the basename of the current image with '.img' replaced
- by '.chg', or, if not running from an image, the default name 'st.chg'."
-
- ChangeFileName notNil ifTrue:[^ ChangeFileName].
- ^ 'changes'.
-
-"/ future versions will have:
-"/ (requires some additionas at other places)
-"/
-"/ ^ self imageBaseName , '.chg'
-
- "
- ObjectMemory nameForChanges
- "
-!
-
-nameForChanges:aFilename
- "set the name of the file where changes are stored into."
-
- ChangeFileName := aFilename
-
- "
- ObjectMemory nameForChanges:'myChanges'
- "
-!
-
-snapShot
- "create a snapshot file containing all of the current state."
-
- self snapShotOn:(self nameForSnapshot)
-
- "
- ObjectMemory snapShot
- "
-!
-
-snapShotOn:aFileName
- "create a snapshot in the given file.
- If the file exists, save it for backup.
- Return true if the snapshot worked, false if it failed for some reason.
- Notify dependents before and after the snapshot operation."
-
- |ok oldImageName|
-
- "
- keep a save version - just in case something
- bad happens while writing the image.
- (could be st/x internal error or file-system errors etc)
- "
- (OperatingSystem isValidPath:aFileName) ifTrue:[
- OperatingSystem renameFile:aFileName to:(aFileName , '.sav').
- ].
-
- "
- give others a chance to fix things
- "
- self changed:#save. "/ will vanish ...
- self changed:#aboutToSnapshot. "/ ... for ST-80 compatibility
-
- "
- ST-80 compatibility; send #preSnapshot to all classes
- "
- Smalltalk allBehaviorsDo:[:aClass |
- aClass preSnapshot
- ].
-
- "
- save the name with it ...
- "
- oldImageName := ImageName.
- ImageName := aFileName.
- ok := self primSnapShotOn:aFileName.
- ImageName := oldImageName.
-
- ok ifTrue:[
- Class addChangeRecordForSnapshot:aFileName.
- ].
-
-
- "
- ST-80 compatibility; send #postSnapshot to all classes
- "
- Smalltalk allBehaviorsDo:[:aClass |
- aClass postSnapshot
- ].
- self changed:#finishedSnapshot. "/ ST-80 compatibility
- ^ ok
-
- "
- ObjectMemory snapShotOn:'myimage.img'
- "
-!
-
-primSnapShotOn:aFileName
- "create a snapshot in the given file.
- Low level entry. Does not notify classes or write an entry to
- the changes file. Also, no image backup is created. Returns true if
- the snapshot worked, false if it failed for some reason.
- This method should not be used in normal cases."
-
- |ok|
-
-%{ /* STACK:32000 */
-
- OBJ __snapShotOn();
- OBJ funny = @symbol(funnySnapshotSymbol);
-
- if (__isString(aFileName)) {
- __BLOCKINTERRUPTS();
- ok = __snapShotOn(__context, _stringVal(aFileName), funny);
- __UNBLOCKINTERRUPTS();
- }
-%}.
- ^ ok
-!
-
allBinaryModulesDo:aBlock
"internal private method - walk over all known binary
modules and evaluate aBlock for each entry.
@@ -3119,159 +2969,203 @@
"
"Modified: 30.8.1995 / 17:29:30 / claus"
-! !
-
-!ObjectMemory class ignoredMethodsFor:'system management'!
-
-applicationImageOn:aFileName for:startupClass selector:startupSelector
- "create a snapshot which will come up without any views
- but starts up an application by sending startupClass the startupSelector.
- This exists to nail down an idea I tried once.
- It is absolutely EXPERIMENTAL and unfinished. Dont use this method."
-
- |viewsKnown savedIdleBlocks savedTimeoutBlocks savedTranscript
- savedRoot|
-
- viewsKnown := Display knownViews.
- savedTranscript := Transcript.
- savedRoot := RootView.
-
- "a kludge: save image with modified knownViews,
- and also Transcript set to StdErr ..."
-
- Display knownViews:nil.
- RootView := nil.
-
- Transcript := Stderr.
- Smalltalk startupClass:startupClass selector:startupSelector arguments:nil.
- self snapShotOn:aFileName.
- Smalltalk startupClass:nil selector:nil arguments:nil.
-
- RootView := savedRoot.
- Transcript := savedTranscript.
- Display knownViews:viewsKnown.
+!
+
+imageBaseName
+ "return a reasonable filename to use as baseName (i.e. without extension).
+ This is the filename of the current image (without '.img') or,
+ if not running from an image, the default name 'st'"
+
+ |nm|
+
+ nm := ImageName.
+ (nm isNil or:[nm isBlank]) ifTrue:[
+ ^ 'st'
+ ].
+ (nm endsWith:'.sav') ifTrue:[
+ nm := nm copyWithoutLast:4
+ ].
+ (nm endsWith:'.img') ifTrue:[
+ ^ nm copyWithoutLast:4
+ ].
+ ^ nm
+
+ "
+ ObjectMemory imageBaseName
+ "
+!
+
+imageName
+ "return the filename of the current image, or nil
+ if not running from an image."
+
+ ^ ImageName
"
- ObjectMemory applicationImageOn:'draw.img' for:DrawTool selector:#start
+ ObjectMemory imageName
"
!
-minimumApplicationImageOn:aFileName for:startupClass selector:startupSelector
- "create a snapshot which will come up without any views
- but starts up an application by sending startupClass the startupSelector.
- All unneeded info is stripped from the saved image.
- This exists to nail down an idea I tried once.
- It is absolutely EXPERIMENTAL and unfinished. Dont use this method."
-
- "create a temporary image, for continuation"
- self snapShotOn:'temp.img'.
-
- Display knownViews do:[:aView |
- aView notNil ifTrue:[
- aView superView isNil ifTrue:[
- aView destroy
- ]
+loadClassBinary:aClassName
+ "find the object file for aClassName and -if found - load it;
+ this one loads precompiled object files"
+
+ |fName newClass|
+
+ fName := self fileNameForClass:aClassName.
+ fName notNil ifTrue:[
+ Class withoutUpdatingChangesDo:
+ [
+ self loadBinary:(fName , '.o')
+ ].
+ newClass := self at:(aClassName asSymbol).
+ (newClass notNil and:[newClass implements:#initialize]) ifTrue:[
+ newClass initialize
]
- ].
-
- self stripImage.
-
- self applicationImageOn:aFileName for:startupClass selector:startupSelector.
-
- "continue in old image"
-
- OperatingSystem exec:(Arguments at:1)
- withArguments:#('smalltalk' '-i' 'temp.img') , (Arguments copyFrom:2)
+ ]
+!
+
+nameForChanges
+ "return a reasonable filename to store the changes into.
+ Currently, this is defined in a classVariable and defaults to 'changes'.
+ In future versions, this will be the basename of the current image with '.img' replaced
+ by '.chg', or, if not running from an image, the default name 'st.chg'."
+
+ ChangeFileName notNil ifTrue:[^ ChangeFileName].
+ ^ 'changes'.
+
+"/ future versions will have:
+"/ (requires some additionas at other places)
+"/
+"/ ^ self imageBaseName , '.chg'
"
- ObjectMemory minimumApplicationImageOn:'draw1.img' for:DrawTool selector:#start
- ObjectMemory applicationImageOn:'draw2.img' for:DrawTool selector:#start
+ ObjectMemory nameForChanges
+ "
+!
+
+nameForChanges:aFilename
+ "set the name of the file where changes are stored into."
+
+ ChangeFileName := aFilename
+
+ "
+ ObjectMemory nameForChanges:'myChanges'
+ "
+!
+
+nameForSnapshot
+ "return a reasonable filename to store the snapshot image into.
+ This is the filename of the current image or,
+ if not running from an image, the default name 'st.img'"
+
+ ^ self imageBaseName , '.img'
+
+ "
+ ObjectMemory nameForSnapshot
"
!
-stripImage
- "remove all unneeded stuff from the image - much more is possible here.
- EXPERIMENTAL and unfinished. Dont use this method."
-
- "remove all class comments & source"
-
- Smalltalk allBehaviorsDo:[:aClass |
- aClass setComment:nil.
- aClass methodArray do:[:aMethod |
- aMethod source:''.
- aMethod category:#none
- ]
- ].
-
- "remove some developpers classes"
-
- Smalltalk at:#Compiler put:Parser.
- Smalltalk at:#Debugger put:MiniDebugger.
- Smalltalk at:#Inspector put:MiniInspector.
- Smalltalk at:#FileBrowser put:nil.
- Smalltalk at:#SystemBrowser put:nil.
- Debugger newDebugger.
-
- self garbageCollect
-! !
-
-!ObjectMemory class methodsFor:'ST-80 compatibility'!
-
-availableFreeBytes
- ^ self freeSpace + self freeListSpace
+nameForSources
+ "return a reasonable filename to store the sources into.
+ This is the basename of the current image with '.img' replaced
+ by '.src', or, if not running from an image, the default name 'st.src'"
+
+ ^ self imageBaseName , '.src'
"
- ObjectMemory availableFreeBytes
+ ObjectMemory nameForSources
+ "
+!
+
+primSnapShotOn:aFileName
+ "create a snapshot in the given file.
+ Low level entry. Does not notify classes or write an entry to
+ the changes file. Also, no image backup is created. Returns true if
+ the snapshot worked, false if it failed for some reason.
+ This method should not be used in normal cases."
+
+ |ok|
+
+%{ /* STACK:32000 */
+
+ OBJ __snapShotOn();
+ OBJ funny = @symbol(funnySnapshotSymbol);
+
+ if (__isString(aFileName)) {
+ __BLOCKINTERRUPTS();
+ ok = __snapShotOn(__context, _stringVal(aFileName), funny);
+ __UNBLOCKINTERRUPTS();
+ }
+%}.
+ ^ ok
+!
+
+snapShot
+ "create a snapshot file containing all of the current state."
+
+ self snapShotOn:(self nameForSnapshot)
+
+ "
+ ObjectMemory snapShot
"
!
-current
- ^ self
-!
-
-growMemoryBy:numberOfBytes
- ^ self moreOldSpace:numberOfBytes
-!
-
-numOopsNumBytes
- ^ Array with:(self numberOfObjects)
- with:(self bytesUsed)
+snapShotOn:aFileName
+ "create a snapshot in the given file.
+ If the file exists, save it for backup.
+ Return true if the snapshot worked, false if it failed for some reason.
+ Notify dependents before and after the snapshot operation."
+
+ |ok oldImageName|
+
+ "
+ keep a save version - just in case something
+ bad happens while writing the image.
+ (could be st/x internal error or file-system errors etc)
+ "
+ (OperatingSystem isValidPath:aFileName) ifTrue:[
+ OperatingSystem renameFile:aFileName to:(aFileName , '.sav').
+ ].
+
+ "
+ give others a chance to fix things
+ "
+ self changed:#save. "/ will vanish ...
+ self changed:#aboutToSnapshot. "/ ... for ST-80 compatibility
"
- ObjectMemory numOopsNumBytes
+ ST-80 compatibility; send #preSnapshot to all classes
"
-!
-
-bytesPerOOP
- "return the number of bytes an object reference (for example: an instvar)
- takes"
-
-%{ /* NOCONTEXT */
- RETURN(__MKSMALLINT(sizeof(OBJ)));
-%}
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass preSnapshot
+ ].
"
- ObjectMemory bytesPerOOP
+ save the name with it ...
"
-!
-
-bytesPerOTE
- "return the number of overhead bytes of an object.
- i.e. the number of bytes in every objects header."
-
-%{ /* NOCONTEXT */
- RETURN(__MKSMALLINT(OHDR_SIZE));
-%}
+ oldImageName := ImageName.
+ ImageName := aFileName.
+ ok := self primSnapShotOn:aFileName.
+ ImageName := oldImageName.
+
+ ok ifTrue:[
+ Class addChangeRecordForSnapshot:aFileName.
+ ].
+
"
- ObjectMemory bytesPerOTE
+ ST-80 compatibility; send #postSnapshot to all classes
"
-!
-
-globalCompactingGC
- self garbageCollect
-!
-
-compactingGC
- self garbageCollect
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass postSnapshot
+ ].
+ self changed:#finishedSnapshot. "/ ST-80 compatibility
+ ^ ok
+
+ "
+ ObjectMemory snapShotOn:'myimage.img'
+ "
! !
+
+ObjectMemory initialize!