Vm-dev November 2022

vm-dev@lists.squeakfoundation.org

11 participants
72 discussions

[OpenSmalltalk/opensmalltalk-vm] BitBlt rgbMul is broken for depth 1 and not correctly rounded above depth 4 (Issue #651)
by Nicolas Cellier 24 Nov '23

24 Nov '23

In depth 1, the resulting bits will always be 0. It's not a big problem because rgbMul is just a bitAnd operation at this depth. So a quick workaround would be to detect the case in BitBltSimulation destDepth = 1 ifTrue: [^self bitAnd: sourceWord with: destinationWord]. That would also accelerate the Bit BLock Transfer operation, so it's a good hack. But there is more. What we want is multiply ratios in interval [0,1]. dstRatio * srcRatio Our implementation is scaled ratio (scaled by `1 << nBits - 1`): src := (srcRatio * scale) rounded. dst := (dstRatio * scale) rounded. So what we want is: ((dst/scale) * (src/scale) * scale) rounded that is: (dst*src / (1<<nBits-1)) rounded Unfortunately, that's the other grief with the current implementation used for rounding: (dst+1)*(src+1) - 1 >> nBits It only equals correctly rounded operation for depths 2 and 4. For rounding we might use: (((dst/scale) * (src/scale) + 0.5) * scale) truncated. that is expressed with truncated division: dst*src + (scale+1//2) // scale So here is a nicer formulation for doing the job at any depth (including 5bits rgb channels for 16 bits depth) with correctly rounded division: aux := src * dst + (1 << (nBits - 1)). "add mid-scale for rounding" result := aux << (nBits - 1) + aux << (nBits -1). "divide by scale" This is because instead of dividing by scale, we can multiply by shifted inverse (sort of double precision), then shift right. (2 to: 32) allSatisfy: [:nBits | (1 << (nBits * 2) / (1 << nBits - 1)) rounded = (1 << nBits + 1)]. Multiplying by this inverse is easy and cheap: x * (1 << nBits + 1) = (x << nBits + x). And then applying the right shift `>> (2 * nBits)` is equivalent to: x >> nBits + x >> nBits. We must first add 0.5 (scaled), that is `src * dst + (1 << (nBits -1))` - our formulation of aux, and we're done. We verify: { (0 to: 1<<20-1) allSatisfy: [:i | (1<<9+i)>>10+ (1<<9+i)>>10 = (i/1023) rounded]. (0 to: 1<<18-1) allSatisfy: [:i | (1<<8+i)>>9+ (1<<8+i)>>9 = (i/511) rounded]. (0 to: 1<<16-1) allSatisfy: [:i | (1<<7+i)>>8+ (1<<7+i)>>8 = (i/255) rounded]. (0 to: 1<<14-1) allSatisfy: [:i | (1<<6+i)>>7+ (1<<6+i)>>7 = (i/127) rounded]. (0 to: 1<<12-1) allSatisfy: [:i | (1<<5+i)>>6+ (1<<5+i)>>6 = (i/63) rounded]. (0 to: 1<<10-1) allSatisfy: [:i | (1<<4+i)>>5+ (1<<4+i)>>5 = (i/31) rounded]. (0 to: 1<<8-1) allSatisfy: [:i | (1<<3+i)>>4+ (1<<3+i)>>4 = (i/15) rounded]. (0 to: 1<<6-1) allSatisfy: [:i | (1<<2+i)>>3+ (1<<2+i)>>3 = (i/7) rounded]. (0 to: 1<<4-1) allSatisfy: [:i | (1<<1+i)>>2+ (1<<1+i)>>2 = (i/3) rounded]. } allSatisfy: #yourself. The nice thing is that above down-scaling operation can be multiplexed. Suppose that we have p groups of 2*nBits `M` holding square-scale multiplication of each channel concatenated in a double-Word-Mul. doubleWordMul = Mp .... M5 M3 M1 Note we arrange to have odd channels in low word, and even channels in high word. We first form a `groupMask` on a word with (p+1)/2 groups of nBits alternating all one `i` and all zero `o`, `oioi...ioi`. channelMask := 1 << nBits - 1. groupMask := 0. 0 to: wordBits // (2 * nBits) do: [:i | groupMask = groupMask << (2 * nBits) + channelMask]. Where wordBits is the number of bits in a word (usually we want to operate on 32 bits words in BitBlt). We form the `doubleGroupMask` on a double-word with p groups of 2*nBits `oi`: doubleGroupMask := groupMask >> nBits. doubleGroupMask := doubleGroupMask << wordBits + groupMask. And we perform the division by scale: doubleWordMul := (doubleWordMul >> nBits bitAnd: doubleGroupMask) + doubleWord >> nBits bitAnd: doubleGroupMask. At this stage we obtain a double word containing scaled multiplicands interleaved with groups of nBits zeros: o mp ... o m3 o m1 Now the final result can be obtained by shifting back: doubleWordMul >> (wordBits - nBits) + (doubleWordMul bitAnd: groupMask) The only problem remaining is how to obtain the squared-scale multiplicands. It would be easy to form the alternate even-odd channels for each src and dst operands: doubleWordSrc := src >> nBits bitAnd: groupMask. doubleWordSrc := doubleWordSrc << wordBits + (src bitAnd: groupMask). doubleWordDst := dst >> nBits bitAnd: groupMask. doubleWordDst := doubleWordDst << wordBits + (dst bitAnd: groupMask). we now get `o sp ... o s3 o s1` and `0 dp ... o d3 o d1`, but we would now need a SIMD integer multiplication operating on groups of 2*nBits in parallel... We don't have that, at least in portable C code. So we still have to emulate it with a loop. half := 1 << (nBits - 1). shift := 0. doubleWordMul := 0 0 to: nChannels - 1 do: [:i | doubleWordMul := doubleWordMul + (((doubleWordSrc >> shift bitAnd: channelMask) * (doubleWordSrc >> shift bitAnd: channelMask) + half) << shift). shift := shift + nBits + nBits]. We know that each operation cannot overflow on upper neighbour group of 2*nBits, because the maximum value is: (1<<nBits-1) squared + (1 << (nBits-1)) = 1 << (2*nBits) - (2*(1<<nBits)) + (1 << (nBits-1)) - 1 < (1 << (2*nBits) - 1) It remains the odd case of 16 bits depth, which has 3 groups of 5 bits and a leading zero. I believe that above algorithm works without splitting in two half-words... To be tested. We have gathered the pieces for a correctly rounded almost-multiplexed rgbMul. Somehow have our cake and eat it too. -- Reply to this email directly or view it on GitHub: https://github.com/OpenSmalltalk/opensmalltalk-vm/issues/651 You are receiving this because you are subscribed to this thread. Message ID: <OpenSmalltalk/opensmalltalk-vm/issues/651(a)github.com>

2 4

[OpenSmalltalk/opensmalltalk-vm] Allow choosing an image via zenity when no arguments are provided (#408)
by Leon Matthes 05 Jun '23

05 Jun '23

You can view, comment on, or merge this pull request online at: https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/408 -- Commit Summary -- * Add file chooser dialog to squeak.sh.in * Add file chooser dialog to bin.squeak.sh.in -- File Changes -- M platforms/unix/config/bin.squeak.sh.in (13) M platforms/unix/config/squeak.sh.in (13) -- Patch Links -- https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/408.patch https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/408.diff -- You are receiving this because you are subscribed to this thread. Reply to this email directly or view it on GitHub: https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/408

4 8

[OpenSmalltalk/opensmalltalk-vm] Revise docs on HowToBuild on Windows: cygwin tools must be in PATH [ci skip] (PR #657)
by Christoph Thiede 21 Mar '23

21 Mar '23

Otherwise, `MAKEDEBUG.BAT` & Co. might fail if some tools (such as `tee`) are not found. You can view, comment on, or merge this pull request online at: https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/657 -- Commit Summary -- * docs on HowToBuild on Windows: cygwin tools must be in PATH [ci skip] -- File Changes -- M building/win32x86/HowToBuild (1) M building/win64x64/HowToBuild (1) -- Patch Links -- https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/657.patch https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/657.diff -- Reply to this email directly or view it on GitHub: https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/657 You are receiving this because you are subscribed to this thread. Message ID: <OpenSmalltalk/opensmalltalk-vm/pull/657(a)github.com>

4 8

[OpenSmalltalk/opensmalltalk-vm] Proposed Document Addition: riscv64 porting notes (PR #650)
by Ken Dickey 23 Jan '23

23 Jan '23

A slightly cleaned up version of what I poster earlier. Just a schematic description which may be of use down the line. [Doc only; no code changes] You can view, comment on, or merge this pull request online at: https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/650 -- Commit Summary -- * proposed doc * nits * added ref -- File Changes -- A PortingNotesRISCV64.md (322) -- Patch Links -- https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/650.patch https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/650.diff -- Reply to this email directly or view it on GitHub: https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/650 You are receiving this because you are subscribed to this thread. Message ID: <OpenSmalltalk/opensmalltalk-vm/pull/650(a)github.com>

1 3

Polyphemus, a
by Pierre Misse 28 Dec '22

28 Dec '22

Hello, My name is Pierre Misse-Chanabier. I'm finishing my PhD in the RMOD team on testing Virtual Machines soon. I wanted to share with you a project I did with Theo Rogliano on the Pharo VM, which should be straightforward to use on the OpenSmalltalk-VM as well. Except for the UI, of course ! In a nutshell, Polyphemus [1] reifies OOPs in the memory to propose a representation that is closer to the language level. Therefore, it provides a layer that is easier to work with. For example, if an OOP is pointing to a class, I can ask for its name, inspect it as I would at the language level, or send message special to a class that shouldn't work on a string OOP for example. We have develop a few visualizations and basic tools for the Pharo VM. Particularly, we have been able to fix error containing meta-errors and memory corruptions. You may have encounter a video of this at the Technological Innovation award at ESUG 2022 [2]. We have also wrote a paper that will be published soon at VMIL 2022 [3]. I haven't checked in quite a long time, but I think that most (or all) of the simulator features we use in Polyphemus are available in the OpenSmalltal-VM as well. I hope it'll be useful to someone else, or at least interesting to some of you :) Pierre [1] Github Repository: https://github.com/hogoww/Polyphemus/ [2] Video Presentation for Esug Innovation award (I was unable to present it myself): https://www.youtube.com/watch?v=zf3cCtNW830 [3] VMIL'22: Ease VM Level Tooling with Language Level Ordinary Object Pointers https://hal.inria.fr/hal-03827632 (preprint)

1 1

[OpenSmalltalk/opensmalltalk-vm] configure.ac: Fix tzet typo for tzset (PR #660)
by Florian Weimer 30 Nov '22

30 Nov '22

Found with an instrumented compiler for: * https://fedoraproject.org/wiki/Changes/PortingToModernC * https://fedoraproject.org/wiki/Toolchain/PortingToModernC You can view, comment on, or merge this pull request online at: https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/660 -- Commit Summary -- * configure.ac: Fix tzet typo for tzset -- File Changes -- M platforms/unix/config/acinclude.m4 (2) M platforms/unix/config/configure (2) -- Patch Links -- https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/660.patch https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/660.diff -- Reply to this email directly or view it on GitHub: https://github.com/OpenSmalltalk/opensmalltalk-vm/pull/660 You are receiving this because you are subscribed to this thread. Message ID: <OpenSmalltalk/opensmalltalk-vm/pull/660(a)github.com>

2 2

[OpenSmalltalk/opensmalltalk-vm] 82f453: configure.ac: Fix tzet typo for tzset
by Tobias Pape 30 Nov '22

30 Nov '22

Branch: refs/heads/Cog Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: 82f45303147cae5072d443fe808f508308c6e778 https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/82f45303147cae5072… Author: Florian Weimer <fweimer(a)redhat.com> Date: 2022-11-30 (Wed, 30 Nov 2022) Changed paths: M platforms/unix/config/acinclude.m4 M platforms/unix/config/configure Log Message: ----------- configure.ac: Fix tzet typo for tzset Commit: 8b7a674771547a57e14c5a62fa612bd14e08ff37 https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/8b7a674771547a57e1… Author: Tobias Pape <krono(a)users.noreply.github.com> Date: 2022-11-30 (Wed, 30 Nov 2022) Changed paths: M platforms/unix/config/acinclude.m4 M platforms/unix/config/configure Log Message: ----------- Merge pull request #660 from fweimer-rh/tzet configure.ac: Fix tzet typo for tzset Compare: https://github.com/OpenSmalltalk/opensmalltalk-vm/compare/bd60a484fb58...8b…

1 0

Review Request: noUNCPaths
by christoph.thiede＠student.hpi.uni-potsdam.de 30 Nov '22

30 Nov '22

Repairs FileDirectory>>#exists for long paths (> 260 characters) on Windows by well-defining an edge case in the Windows implementation of the FilePlugin primitiveDirectoryEntry, that is, to specify a single dot (.) as the file name. Documents the present limitations to syntactic sugar in long file paths in the platform code, the relevant plugin methods, and on the image side of Squeak Trunk. An alternative consideration was to rewrite FileDirectory>>#exists to pass an empty string as file name to the primitive instead of modifying the VM, but strictly speaking, even this would have exploited an undefined behavior in the VM plugin, and an empty file name would be less idiomatic than a single dot. For the original bug report, see: https://github.com/hpi-swa-teaching/Morphic-Testing-Framework/issues/13 Thanks to Marcel (mt) for his support! Signed-off-by: Christoph Thiede <christoph.thiede(a)student.hpi.de> --- Note that this mail contains both a git diff for the changes in the opensmalltalk-vm repository and a changeset for the changes in the Squeak Trunk so that they may be reviewed together. Any feedback on this formatting approach will be appreciated. Excited to receive your review! platforms/win32/vm/sqWin32Directory.c | 29 +++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/platforms/win32/vm/sqWin32Directory.c b/platforms/win32/vm/sqWin32Directory.c index 2b3d090ec..0aa5c2108 100644 --- a/platforms/win32/vm/sqWin32Directory.c +++ b/platforms/win32/vm/sqWin32Directory.c @@ -196,6 +196,15 @@ sqInt dir_Lookup(char *pathString, sqInt pathLength, sqInt index, /* Lookup the index-th entry of the directory with the given path, starting at the root of the file system. Set the name, name length, creation date, creation time, directory flag, and file size (if the entry is a file). + + Note that, due to restrictions by the operating system, this method only + has limited support for paths longer than 260 characters. In the case of + longer paths, they must not contain syntactic sugar such as ".", "..", or + "a/b".* For more details, see: + https://learn.microsoft.com/en-us/windows/win32/fileio/naming-a-file#paths + *) Long paths are automatically converted into UNC paths, which only + support a subset of the normal path syntax. + Return: 0 if a entry is found at the given index 1 if the directory has fewer than index entries @@ -354,6 +363,20 @@ sqInt dir_EntryLookup(char *pathString, sqInt pathLength, char* nameString, sqIn /* Lookup a given file in a given named directory. Set the name, name length, creation date, creation time, directory flag, and file size (if the entry is a file). + + Note that, due to restrictions by the operating system, this method only + has limited support for paths longer than 260 characters (for the full + path concatenated from the directory path, a backslash, and the file + name). In the case of longer paths, neither the path nor the file name + must contain syntactic sugar such as ".", "..", or "a/b".* However, this + method defines a single (!) convention for passing nameString as ".", + which is also supported for long paths. This convention is provided for + an efficient existence check of the directory (e.g., + FileDirectory>>#exists). For more details, see: + https://learn.microsoft.com/en-us/windows/win32/fileio/naming-a-file#paths + *) Long paths are automatically converted into UNC paths, which only + support a subset of the normal path syntax. + Return: 0 if found (a file or directory 'nameString' exists in directory 'pathString') 1 if the directory has no such entry @@ -416,6 +439,12 @@ sqInt dir_EntryLookup(char *pathString, sqInt pathLength, char* nameString, sqIn fullPath=(char *)calloc(fullPathLength,sizeof(char)); memcpy(fullPath,pathString,pathLength); if (pathString[pathLength-1] != '\\') fullPath[pathLength]='\\'; + if (nameStringLength == 1 && nameString[0] == '.') { + /* special syntax: "." is the current directory. Trim it from the full + path to avoid generating a UNC path with an unresolved ".", which is + not supported there. See comment above. */ + nameStringLength = 0; + } memcpy(fullPath+fullPathLength-nameStringLength,nameString,nameStringLength); /* convert the path name into a null-terminated C string */ -- 2.37.3.windows.1 =============== Summary =============== Change Set: noUNCPaths Date: 30 November 2022 Author: Christoph Thiede Documents the present limitations to syntactic sugar in long file paths in the relevant plugin methods and on the image side. For the original bug report, see: https://github.com/hpi-swa-teaching/Morphic-Testing-Framework/issues/13 Thanks to Marcel (mt) for his support! =============== Diff =============== FileDirectory>>primLookupEntryIn:index: {private} · ct 11/29/2022 20:24 (changed) primLookupEntryIn: fullPath index: index "Look up the index-th entry of the directory with the given fully-qualified path (i.e., starting from the root of the file hierarchy) and return an array containing: <name> <creationTime> <modificationTime> <dirFlag> <fileSize> The empty string enumerates the top-level files or drives. (For example, on Unix, the empty path enumerates the contents of '/'. On Macs and PCs, it enumerates the mounted volumes/drives.) + Note that in general, fullPath must not contain syntactic sugar for the current platform (e.g., '.' or '..', or on Windows, forward slashes instead of backslashes). These conventions are only fully supported on Unix platforms; on Windows, they are only supported for short non-UNC file paths containing max 260 characters. See the comment in the primitive implementation for more details. The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given path is bad." <primitive: 'primitiveDirectoryLookup' module: 'FilePlugin'> ^ #badDirectoryPath FileDirectory>>primLookupEntryIn:name: {private} · ct 11/30/2022 15:38 (changed) primLookupEntryIn: fullPath name: fName - "Look up <fName> (a simple file name) in the directory identified by <fullPath> and return an array containing: <fName> <creationTime> <modificationTime> <dirFlag> <fileSize> On Unix, the empty path denotes '/'. On Macs and PCs, it is the container of the system volumes.) + Note that in general, neither fullPath nor fName must contain syntactic sugar for the current platform (e.g., '.' or '..', or on Windows, forward slashes instead of backslashes). These conventions are only fully supported on Unix platforms; on Windows, they are only supported for short non-UNC file paths containing max 260 characters (for the full path concatenated from the directory path, a backslash, and the file name). As a single (!) exception, the file name may always be a single dot ('.'), which is supported for an efficient existence test of the directory path (e.g., FileDirectory>>#exists). See the comment in the primitive implementation for more details. The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given path is bad." <primitive: 'primitiveDirectoryEntry' module: 'FilePlugin'> ^ #primFailed "to distinguish from nil" FilePlugin>>primitiveDirectoryEntry {directory primitives} · ct 11/30/2022 15:13 (changed) primitiveDirectoryEntry "Two arguments - directory path, and simple file name; returns an array (see primitiveDirectoryLookup) describing the file or directory, or nil if it does not exist. + + Note that in general, neither the directory path nor the file name must + contain syntactic sugar for the current platform (e.g., '.' or '..', or on + Windows, forward slashes instead of backslashes). These conventions are + only fully supported on Unix platforms; on Windows, they are only + supported for short non-UNC file paths containing max 260 characters (for + the full path concatenated from the directory path, a backslash, and the + file name). As a single (!) exception, the file name may always be a + single dot ('.'), which is supported for an efficient existence test of + the directory path (e.g., FileDirectory>>#exists). See the comment in + sqWin32Directory.c for more details. + Primitive fails if the outer path does not identify a readable directory. (This is a lookup-by-name variant of primitiveDirectoryLookup.)" | requestedName pathName pathNameIndex pathNameSize status entryName entryNameSize createDate modifiedDate dirFlag posixPermissions symlinkFlag fileSize okToList reqNameIndex reqNameSize | <var: 'entryName' declareC: 'char entryName[256]'> <var: 'pathNameIndex' type: #'char *'> <var: 'reqNameIndex' type: #'char *'> <var: 'fileSize' type: #squeakFileOffsetType> <export: true> requestedName := interpreterProxy stackValue: 0. pathName := interpreterProxy stackValue: 1. (interpreterProxy isBytes: pathName) ifFalse: [^interpreterProxy primitiveFail]. "Outbound string parameters" pathNameIndex := interpreterProxy firstIndexableField: pathName. pathNameSize := interpreterProxy byteSizeOf: pathName. reqNameIndex := interpreterProxy firstIndexableField: requestedName. reqNameSize := interpreterProxy byteSizeOf: requestedName. self cCode: '' inSmalltalk: [entryName := ByteString new: 256. entryNameSize := createDate := modifiedDate := dirFlag := fileSize := posixPermissions := symlinkFlag := nil]. "If the security plugin can be loaded, use it to check for permission. If not, assume it's ok" okToList := sCLPfn ~= 0 ifTrue: [self cCode: '((sqInt (*)(char *, sqInt))sCLPfn)(pathNameIndex, pathNameSize)' inSmalltalk: [true]] ifFalse: [true]. status := okToList ifTrue: [self dir_EntryLookup: pathNameIndex _: pathNameSize _: reqNameIndex _: reqNameSize _: entryName _: (self addressOf: entryNameSize put: [:v| entryNameSize := v]) _: (self addressOf: createDate put: [:v| createDate := v]) _: (self addressOf: modifiedDate put: [:v| modifiedDate := v]) _: (self addressOf: dirFlag put: [:v| dirFlag := v]) _: (self addressOf: fileSize put: [:v| fileSize := v]) _: (self addressOf: posixPermissions put: [:v| posixPermissions := v]) _: (self addressOf: symlinkFlag put: [:v| symlinkFlag := v])] ifFalse: [DirNoMoreEntries]. interpreterProxy failed ifTrue: [^nil]. status = DirNoMoreEntries ifTrue: "no entry; return nil" [interpreterProxy "pop pathName, index, rcvr" pop: 3 thenPush: interpreterProxy nilObject. ^nil]. status = DirBadPath ifTrue: [^interpreterProxy primitiveFail]."bad path" interpreterProxy pop: 3 "pop pathName, index, rcvr" thenPush: (self cppIf: PharoVM ifTrue: [self makeDirEntryName: entryName size: entryNameSize createDate: createDate modDate: modifiedDate isDir: dirFlag fileSize: fileSize posixPermissions: posixPermissions isSymlink: symlinkFlag] ifFalse: [self makeDirEntryName: entryName size: entryNameSize createDate: createDate modDate: modifiedDate isDir: dirFlag fileSize: fileSize]) FilePlugin>>primitiveDirectoryLookup {directory primitives} · ct 11/30/2022 15:00 (changed) primitiveDirectoryLookup + "Two arguments - directory path, and an index to an item; returns an array (see primitiveDirectoryLookup) describing the file or directory, or nil if it does not exist. + + Note that in general, the directory path must not contain syntactic sugar for the current platform (e.g., '.' or '..', or on Windows, forward slashes instead of backslashes). These conventions are only fully supported on Unix platforms; on Windows, they are only supported for short non-UNC file paths containing max 260 characters. See the comment in sqWin32Directory.c for more details. + + Primitive fails if the outer path does not identify a readable directory. (For a lookup-by-name variant, see primitiveDirectoryEntry.)" | index pathName pathNameIndex pathNameSize status entryName entryNameSize createDate modifiedDate dirFlag symlinkFlag posixPermissions fileSize okToList | <var: 'entryName' declareC: 'char entryName[256]'> <var: 'pathNameIndex' type: #'char *'> <var: 'fileSize' type: #squeakFileOffsetType> <export: true> index := interpreterProxy stackIntegerValue: 0. pathName := interpreterProxy stackValue: 1. (interpreterProxy isBytes: pathName) ifFalse: [^interpreterProxy primitiveFail]. pathNameIndex := interpreterProxy firstIndexableField: pathName. pathNameSize := interpreterProxy byteSizeOf: pathName. self cCode: '' inSmalltalk: [entryName := ByteString new: 256. entryNameSize := createDate := modifiedDate := dirFlag := fileSize := posixPermissions := symlinkFlag := nil]. "If the security plugin can be loaded, use it to check for permission. If not, assume it's ok" okToList := sCLPfn ~= 0 ifTrue: [self cCode: '((sqInt (*)(char *, sqInt))sCLPfn)(pathNameIndex, pathNameSize)' inSmalltalk: [true]] ifFalse: [true]. status := okToList ifTrue: [self dir_Lookup: pathNameIndex _: pathNameSize _: index _: entryName _: (self addressOf: entryNameSize put: [:v| entryNameSize := v]) _: (self addressOf: createDate put: [:v| createDate := v]) _: (self addressOf: modifiedDate put: [:v| modifiedDate := v]) _: (self addressOf: dirFlag put: [:v| dirFlag := v]) _: (self addressOf: fileSize put: [:v| fileSize := v]) _: (self addressOf: posixPermissions put: [:v| posixPermissions := v]) _: (self addressOf: symlinkFlag put: [:v| symlinkFlag := v])] ifFalse: [DirNoMoreEntries]. interpreterProxy failed ifTrue: [^nil]. status = DirNoMoreEntries ifTrue: "no more entries; return nil" [interpreterProxy "pop pathName, index, rcvr" pop: 3 thenPush: interpreterProxy nilObject. ^nil]. status = DirBadPath ifTrue: [^interpreterProxy primitiveFail]."bad path" interpreterProxy pop: 3 "pop pathName, index, rcvr" thenPush: (self cppIf: PharoVM ifTrue: [self makeDirEntryName: entryName size: entryNameSize createDate: createDate modDate: modifiedDate isDir: dirFlag fileSize: fileSize posixPermissions: posixPermissions isSymlink: symlinkFlag] ifFalse: [self makeDirEntryName: entryName size: entryNameSize createDate: createDate modDate: modifiedDate isDir: dirFlag fileSize: fileSize]) --- Sent from Squeak Inbox Talk ["noUNCPaths.3.cs"]

1 0

Squeak 6 on SqueakJS
by Vanessa Freudenberg 26 Nov '22

26 Nov '22

... works now with release 1.0.5 of SqueakJS: https://squeak.js.org/run/#zip=https://files.squeak.org/6.0/Squeak6.0-22104… We only had to recognize the new image format – sorry it took me so long. Thank you, Christoph Tiede and Dave Lewis! (https://github.com/codefrau/SqueakJS/pull/138) TODO: actually implement primitive 578 (but then, quite a few non-essential prims are still missing) Enjoy! Vanessa

3 3

VM Maker: VMMaker.oscog.seperateMarking-WoC.3276.mcz
by commits＠source.squeak.org 25 Nov '22

25 Nov '22

Tom Braun uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog.seperateMarking-WoC.3276.mcz ==================== Summary ==================== Name: VMMaker.oscog.seperateMarking-WoC.3276 Author: WoC Time: 25 November 2022, 7:02:47.170615 pm UUID: d1e001c2-9d29-40b8-b91a-5ce550f7f68a Ancestors: VMMaker.oscog.seperateMarking-WoC.3259, VMMaker.oscog-eem.3275 a not bugfree but for basic operations running incremental GC - better error reporting during code gen - self for polymorphic receivers - primitive GCinfo - don't delete reserved empty segments - fix bugs by inserting barriers - initial use for polymorphic selectors =============== Diff against VMMaker.oscog-eem.3275 =============== Item was changed: SystemOrganization addCategory: #'VMMaker-Building'! SystemOrganization addCategory: #'VMMaker-Interpreter'! SystemOrganization addCategory: #'VMMaker-InterpreterSimulation'! SystemOrganization addCategory: #'VMMaker-JIT'! SystemOrganization addCategory: #'VMMaker-JITSimulation'! SystemOrganization addCategory: #'VMMaker-Multithreading'! SystemOrganization addCategory: #'VMMaker-Plugins'! SystemOrganization addCategory: #'VMMaker-Plugins-FFI'! SystemOrganization addCategory: #'VMMaker-Plugins-IOS'! SystemOrganization addCategory: #'VMMaker-PostProcessing'! SystemOrganization addCategory: #'VMMaker-SmartSyntaxPlugins'! + SystemOrganization addCategory: #'VMMaker-SpurGarbageCollector'! + SystemOrganization addCategory: #'VMMaker-SpurGarbageCollectorSimulation'! SystemOrganization addCategory: #'VMMaker-SpurMemoryManager'! SystemOrganization addCategory: #'VMMaker-SpurMemoryManagerSimulation'! - SystemOrganization addCategory: #'VMMaker-V3MemoryManager'! SystemOrganization addCategory: #'VMMaker-Support'! SystemOrganization addCategory: #'VMMaker-Tests'! SystemOrganization addCategory: #'VMMaker-Translation to C'! SystemOrganization addCategory: #'VMMaker-Utilities'! + SystemOrganization addCategory: #'VMMaker-V3MemoryManager'! Item was changed: ----- Method: CCodeGenerator>>checkClassForNameConflicts: (in category 'error notification') ----- checkClassForNameConflicts: aClass "Verify that the given class does not have constant, variable, or method names that conflict with those of previously added classes. Raise an error if a conflict is found, otherwise just return." "check for constant name collisions in class pools" aClass classPool associationsDo: [:assoc | (constants includesKey: assoc key) ifTrue: [self error: 'Constant ', assoc key, ' was defined in a previously added class']]. "and in shared pools" (aClass sharedPools reject: [:pool| pools includes: pool]) do: [:pool | pool bindingsDo: [:assoc | (constants includesKey: assoc key) ifTrue: [self error: 'Constant ', assoc key, ' was defined in a previously added class']]]. "check for instance variable name collisions" (aClass inheritsFrom: VMStructType) ifFalse: [(self instVarNamesForClass: aClass) do: [:varName | (variables includes: varName) ifTrue: [self error: 'Instance variable ', varName, ' was defined in a previously added class']]]. "check for method name collisions" aClass selectors do: [:sel | | tmeth meth | ((self shouldIncludeMethodFor: aClass selector: sel) and: [(tmeth := methods at: sel ifAbsent: nil) notNil and: [(aClass isStructClass and: [(aClass isAccessor: sel) and: [(methods at: sel) isStructAccessor]]) not and: [(meth := aClass >> sel) isSubclassResponsibility not and: [(aClass includesBehavior: tmeth definingClass) not]]]]) ifTrue: [((aClass >>sel) pragmaAt: #option:) + ifNil: [self error: 'Method ', sel, ' was previously defined in: ' , tmeth definingClass , ' and now in: ', aClass] - ifNil: [self error: 'Method ', sel, ' was defined in a previously added class.'] ifNotNil: [logger ensureCr; show: 'warning, method ', aClass name, '>>', sel storeString, ' overrides ', tmeth definingClass, '>>', sel storeString; cr]]]! Item was added: + ----- Method: CCodeGenerator>>ifStaticallyResolvedPolymorphicReceiverThenUpdateSelectorIn:fromMethodIn: (in category 'public') ----- + ifStaticallyResolvedPolymorphicReceiverThenUpdateSelectorIn: aSendNode fromMethodIn: aClass + "We allow a limited amount of polymorphism; if a class chooses, its selectors can be + prefixed with a given string to disambiguate. This hack allows us to use two different + compaction algorithms with the same API at the same time; the selection being done + by a class which holds the flag stating which algorithm is in effect at the current time." + | class | + staticallyResolvedPolymorphicReceivers ifNil: [^self]. + aSendNode receiver isVariable ifFalse: + [^self]. + + class := (aSendNode receiver name = 'self' and: [aClass hasPolymorphicSelectors]) + ifTrue: [aClass] + ifFalse: [staticallyResolvedPolymorphicReceivers + at: aSendNode receiver name + ifAbsent: [^self]]. + + aSendNode selector: (class staticallyResolvePolymorphicSelector: aSendNode selector)! Item was added: + ----- Method: CoInterpreter>>incrementalMarkAndTracePrimTraceLog (in category 'debug support') ----- + incrementalMarkAndTracePrimTraceLog + "The prim trace log is a circular buffer of objects. If there is + an entry at primTraceLogIndex - 1 \\ PrimTraceBufferSize it has entries. + If there is something at primTraceLogIndex it has wrapped." + <inline: false> + | entryOop marker | + "do not remove. Necessary for resolving polymorphic receiver" + marker := objectMemory marker. + + (primTraceLog at: (self safe: primTraceLogIndex - 1 mod: PrimTraceLogSize)) = 0 ifTrue: + [^self]. + (primTraceLog at: primTraceLogIndex) ~= 0 ifTrue: + [primTraceLogIndex to: PrimTraceLogSize - 1 do: + [:i| + entryOop := primTraceLog at: i. + (entryOop ~= 0 + and: [objectMemory isNonImmediate: entryOop]) ifTrue: + [marker markAndShouldScan: entryOop]]]. + 0 to: primTraceLogIndex - 1 do: + [:i| + entryOop := primTraceLog at: i. + (entryOop ~= 0 + and: [objectMemory isNonImmediate: entryOop]) ifTrue: + [marker markAndShouldScan: entryOop]]! Item was added: + ----- Method: CoInterpreter>>incrementalMarkAndTraceStackPage: (in category 'object memory support') ----- + incrementalMarkAndTraceStackPage: thePage + | theSP theFP frameRcvrOffset callerFP oop marker | + <var: #thePage type: #'StackPage *'> + <var: #theSP type: #'char *'> + <var: #theFP type: #'char *'> + <var: #frameRcvrOffset type: #'char *'> + <var: #callerFP type: #'char *'> + <inline: false> + + "do not remove. Necessary for resolving polymorphic receiver" + marker := objectMemory marker. + + self assert: (stackPages isFree: thePage) not. + self assert: (self ifCurrentStackPageHasValidHeadPointers: thePage). + self assert: thePage trace ~= StackPageTraced. + thePage trace: StackPageTraced. + + theSP := thePage headSP. + theFP := thePage headFP. + "Skip the instruction pointer on top of stack of inactive pages." + thePage = stackPage ifFalse: + [theSP := theSP + objectMemory wordSize]. + [frameRcvrOffset := self frameReceiverLocation: theFP. + [theSP <= frameRcvrOffset] whileTrue: + [oop := stackPages longAt: theSP. + (objectMemory isOopForwarded: oop) ifTrue: + [oop := objectMemory followForwarded: oop. + stackPages longAt: theSP put: oop]. + (objectMemory isImmediate: oop) ifFalse: + [marker markAndShouldScan: oop]. + theSP := theSP + objectMemory wordSize]. + (self frameHasContext: theFP) ifTrue: + [self assert: (objectMemory isContext: (self frameContext: theFP)). + marker markAndShouldScan: (self frameContext: theFP)]. + (self isMachineCodeFrame: theFP) + ifTrue: [self markAndTraceMachineCodeMethod: (self mframeCogMethod: theFP)] + ifFalse: [marker markAndShouldScan: (self iframeMethod: theFP)]. + (callerFP := self frameCallerFP: theFP) ~= 0] whileTrue: + [theSP := theFP + FoxCallerSavedIP + objectMemory wordSize. + theFP := callerFP]. + theSP := theFP + FoxCallerSavedIP + objectMemory wordSize. "caller ip is ceBaseReturnPC" + [theSP <= thePage baseAddress] whileTrue: + [oop := stackPages longAt: theSP. + (objectMemory isOopForwarded: oop) ifTrue: + [oop := objectMemory followForwarded: oop. + stackPages longAt: theSP put: oop]. + (objectMemory isImmediate: oop) ifFalse: + [marker markAndShouldScan: oop]. + theSP := theSP + objectMemory wordSize]! Item was added: + ----- Method: CoInterpreter>>incrementalMarkAndTraceTraceLog (in category 'object memory support') ----- + incrementalMarkAndTraceTraceLog + "The trace log is a circular buffer of pairs of entries. If there is an entry at + traceLogIndex - 3 \\ TraceBufferSize it has entries. If there is something at + traceLogIndex it has wrapped." + <inline: false> + | limit marker | + "do not remove. Necessary for resolving polymorphic receiver" + marker := objectMemory marker. + + limit := self safe: traceLogIndex - 3 mod: TraceBufferSize. + (traceLog at: limit) = 0 ifTrue: [^self]. + (traceLog at: traceLogIndex) ~= 0 ifTrue: + [limit := TraceBufferSize - 3]. + 0 to: limit by: 3 do: + [:i| | oop | + oop := traceLog at: i. + (objectMemory isImmediate: oop) ifFalse: + [marker markAndShouldScan: oop]. + oop := traceLog at: i + 1. + (objectMemory isImmediate: oop) ifFalse: + [marker markAndShouldScan: oop]]! Item was added: + ----- Method: CoInterpreterMT>>incrementalMarkAndTraceInterpreterOops (in category 'object memory support') ----- + incrementalMarkAndTraceInterpreterOops + "Override to mark the awolProcesses" + <var: #vmThread type: #'CogVMThread *'> + + "do not remove. Necessary for resolving polymorphic receiver" + | marker | + marker := objectMemory marker. + + super incrementalMarkAndTraceInterpreterOops. + + "Per-thread state; trace each thread's own newMethod and stack of awol processes." + 1 to: cogThreadManager getNumThreads do: + [:i| | vmThread | + vmThread := cogThreadManager vmThreadAt: i. + vmThread state ifNotNil: + [vmThread newMethodOrNull ifNotNil: + [marker pushOnMarkingStackAndMakeGrey: vmThread newMethodOrNull]. + 0 to: vmThread awolProcIndex - 1 do: + [:j| marker pushOnMarkingStackAndMakeGrey: (vmThread awolProcesses at: j)]]]! Item was added: + ----- Method: CogVMSimulator>>incrementalMarkAndTraceInterpreterOops (in category 'multi-threading simulation switch') ----- + incrementalMarkAndTraceInterpreterOops + "This method includes or excludes CoInterpreterMT methods as required. + Auto-generated by CogVMSimulator>>ensureMultiThreadingOverridesAreUpToDate" + + ^self perform: #incrementalMarkAndTraceInterpreterOops + withArguments: {} + inSuperclass: (cogThreadManager ifNil: [CoInterpreterPrimitives] ifNotNil: [CoInterpreterMT])! Item was added: + CogClass subclass: #FreeChunkManager + instanceVariableNames: 'manager' + classVariableNames: '' + poolDictionaries: '' + category: 'VMMaker-SpurMemoryManager'! Item was added: + ----- Method: FreeChunkManager>>addFreeSubTree: (in category 'as yet unclassified') ----- + addFreeSubTree: freeTree + "Add a freeChunk sub tree back into the large free chunk tree. + This is for allocateOldSpaceChunkOf[Exactly]Bytes:[suchThat:]." + | bytesInArg treeNode bytesInNode subNode | + "N.B. *can't* use numSlotsOfAny: because of rounding up of odd slots + and/or step in size at 1032 bytes in 32-bits or 2048 bytes in 64-bits." + self assert: (self isFreeObject: freeTree). + bytesInArg := self bytesInBody: freeTree. + self assert: bytesInArg >= (self numFreeLists * self allocationUnit). + treeNode := manager freeLists at: 0. + self assert: treeNode ~= 0. + [bytesInNode := self bytesInBody: treeNode. + "check for overlap; could write this as self oop: (self objectAfter: freeChunk) isLessThanOrEqualTo: child... + but that relies on headers being correct, etc. So keep it clumsy..." + self assert: ((self oop: freeTree + bytesInArg - self baseHeaderSize isLessThanOrEqualTo: treeNode) + or: [self oop: freeTree isGreaterThanOrEqualTo: treeNode + bytesInNode - self baseHeaderSize]). + self assert: bytesInNode >= (self numFreeLists * self allocationUnit). + self assert: bytesInArg ~= bytesInNode. + bytesInNode > bytesInArg + ifTrue: + [subNode := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: treeNode. + subNode = 0 ifTrue: + [self storePointer: self freeChunkSmallerIndex ofFreeChunk: treeNode withValue: freeTree. + self storePointer: self freeChunkParentIndex ofFreeChunk: freeTree withValue: treeNode. + ^self]] + ifFalse: + [subNode := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: treeNode. + subNode = 0 ifTrue: + [self storePointer: self freeChunkLargerIndex ofFreeChunk: treeNode withValue: freeTree. + self storePointer: self freeChunkParentIndex ofFreeChunk: freeTree withValue: treeNode. + ^self]]. + treeNode := subNode] repeat! Item was added: + ----- Method: FreeChunkManager>>addToFreeList:bytes: (in category 'as yet unclassified') ----- + addToFreeList: freeChunk bytes: chunkBytes + "Add freeChunk to the relevant freeList. + For the benefit of sortedFreeObject:, if freeChunk is large, answer the treeNode it + is added to, if it is added to the next list of a freeTreeNode, otherwise answer 0." + | index | + <var: 'chunkBytes' type: #'usqInt'> + "coInterpreter transcript ensureCr. coInterpreter print: 'freeing '. self printFreeChunk: freeChunk." + self assert: (self isFreeObject: freeChunk). + self assert: chunkBytes = (self bytesInBody: freeChunk). + "Too slow to be enabled byt default but useful to debug Selective... + self deny: (compactor isSegmentBeingCompacted: (segmentManager segmentContainingObj: freeChunk))." + index := chunkBytes / self allocationUnit. + index < manager numFreeLists ifTrue: + [self setNextFreeChunkOf: freeChunk withValue: (manager freeLists at: index) chunkBytes: chunkBytes. + (self isLilliputianSize: chunkBytes) ifFalse: + [self storePointer: self freeChunkPrevIndex ofFreeChunk: freeChunk withValue: 0]. + manager freeLists at: index put: freeChunk. + manager freeListsMask: (manager freeListsMask bitOr: 1 << index). + ^0]. + + ^self addToFreeTree: freeChunk bytes: chunkBytes! Item was added: + ----- Method: FreeChunkManager>>addToFreeTree:bytes: (in category 'as yet unclassified') ----- + addToFreeTree: freeChunk bytes: chunkBytes + "Add freeChunk to the large free chunk tree. + For the benefit of sortedFreeObject:, answer the treeNode it is added + to, if it is added to the next list of a freeTreeNode, otherwise answer 0." + | childBytes parent child | + self initFreeTreeChunk: freeChunk bytes: chunkBytes. + "Large chunk list organized as a tree, each node of which is a list of chunks of the same size. + Beneath the node are smaller and larger blocks." + parent := 0. + child := manager freeLists at: 0. + [child ~= 0] whileTrue: + [childBytes := self bytesInBody: child. + "check for overlap; could write this as self oop: (self objectAfter: freeChunk) isLessThanOrEqualTo: child... + but that relies on headers being correct, etc. So keep it clumsy..." + self assert: ((self oop: freeChunk + chunkBytes - self baseHeaderSize isLessThanOrEqualTo: child) + or: [self oop: freeChunk isGreaterThanOrEqualTo: child + childBytes - self baseHeaderSize]). + childBytes = chunkBytes ifTrue: "size match; add to list at node." + [self setNextFreeChunkOf: freeChunk withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: child) isLilliputianSize: false. + self setNextFreeChunkOf: child withValue: freeChunk isLilliputianSize: false. + ^child]. + "walk down the tree" + parent := child. + child := self fetchPointer: (childBytes > chunkBytes + ifTrue: [self freeChunkSmallerIndex] + ifFalse: [self freeChunkLargerIndex]) + ofFreeChunk: child]. + parent = 0 ifTrue: + [self assert: (manager freeLists at: 0) = 0. + manager freeLists at: 0 put: freeChunk. + manager freeListsMask: (manager freeListsMask bitOr: 1). + ^0]. + self assert: (manager freeListsMask anyMask: 1). + "insert in tree" + self storePointer: self freeChunkParentIndex + ofFreeChunk: freeChunk + withValue: parent. + self storePointer: (childBytes > chunkBytes + ifTrue: [self freeChunkSmallerIndex] + ifFalse: [self freeChunkLargerIndex]) + ofFreeChunk: parent + withValue: freeChunk. + ^0! Item was added: + ----- Method: FreeChunkManager>>allObjectsInFreeTree:do: (in category 'as yet unclassified') ----- + allObjectsInFreeTree: freeNode do: aBlock + | listNode | + freeNode = 0 ifTrue: [^0]. + listNode := freeNode. + [listNode ~= 0] whileTrue: + [aBlock value: listNode. + listNode := self fetchPointer: self freeChunkNextIndex ofFreeChunk: listNode]. + self allObjectsInFreeTree: (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: freeNode) + do: aBlock. + self allObjectsInFreeTree: (self fetchPointer: self freeChunkLargerIndex ofFreeChunk: freeNode) + do: aBlock! Item was added: + ----- Method: FreeChunkManager>>allObjectsInFreeTreeDo: (in category 'as yet unclassified') ----- + allObjectsInFreeTreeDo: aBlock + "Enumerate all objects in the free tree (in order, smaller to larger). + This is an iterative version so that the block argument can be + inlined by Slang. The trick to an iterative binary tree application is + to apply the function on the way back up when returning from a + particular direction, in this case up from the larger child." + <inline: true> + self freeTreeNodesDo: + [:freeTreeNode| | next | + next := freeTreeNode. + [aBlock value: next. + next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: next. + next ~= 0] whileTrue. + freeTreeNode]! Item was added: + ----- Method: FreeChunkManager>>allocateLargestFreeChunk (in category 'as yet unclassified') ----- + allocateLargestFreeChunk + "Answer the largest free chunk in the free lists." + <inline: false> + | freeChunk next | + "would like to use ifNotNil: but the ^next inside the ^blah ifNotNil: confused Slang" + freeChunk := self findLargestFreeChunk. + freeChunk ifNil: [^nil]. + "This will be the node, not a list element. Answer a list element in preference." + next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk. + next ~= 0 ifTrue: + [self assert: (self bytesInBody: freeChunk) >= self numFreeLists. "findLargestFreeChunk searches only the tree" + self + setNextFreeChunkOf: freeChunk + withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: next) + isLilliputianSize: false. + ^next]. + self unlinkSolitaryFreeTreeNode: freeChunk. + ^freeChunk! Item was added: + ----- Method: FreeChunkManager>>allocateOldSpaceChunkOfBytes:suchThat: (in category 'as yet unclassified') ----- + allocateOldSpaceChunkOfBytes: chunkBytes suchThat: acceptanceBlock + "Answer a chunk of oldSpace from the free lists that satisfies acceptanceBlock, + if available, otherwise answer nil. Break up a larger chunk if one of the exact + size cannot be found. N.B. the chunk is simply a pointer, it has no valid header. + The caller *must* fill in the header correctly." + <var: #chunkBytes type: #usqInt> + | initialIndex node next prev index child childBytes acceptedChunk acceptedNode | + <inline: true> "must inline for acceptanceBlock" + "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" + manager totalFreeOldSpace: manager totalFreeOldSpace - chunkBytes. "be optimistic (& don't wait for the write)" + initialIndex := chunkBytes / self allocationUnit. + (initialIndex < self numFreeLists and: [1 << initialIndex <= manager freeListsMask]) ifTrue: + [(manager freeListsMask anyMask: 1 << initialIndex) ifTrue: + [(node := manager freeLists at: initialIndex) = 0 + ifTrue: [manager freeListsMask: manager freeListsMask - (1 << initialIndex)] + ifFalse: + [prev := 0. + [node ~= 0] whileTrue: + [self assert: node = (self startOfObject: node). + self assertValidFreeObject: node. + next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. + (acceptanceBlock value: node) ifTrue: + [prev = 0 + ifTrue: [self unlinkFreeChunk: node atIndex: initialIndex chunkBytes: chunkBytes] + ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. + ^node]. + prev := node. + node := next]]]. + "first search for free chunks of a multiple of chunkBytes in size" + index := initialIndex. + [(index := index + initialIndex) < self numFreeLists + and: [1 << index <= manager freeListsMask]] whileTrue: + [(manager freeListsMask anyMask: 1 << index) ifTrue: + [(node := manager freeLists at: index) = 0 + ifTrue: [manager freeListsMask: manager freeListsMask - (1 << index)] + ifFalse: + [prev := 0. + [node ~= 0] whileTrue: + [self assert: node = (self startOfObject: node). + self assertValidFreeObject: node. + next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. + (acceptanceBlock value: node) ifTrue: + [prev = 0 + ifTrue: [self unlinkFreeChunk: node atIndex: index isLilliputianSize: false.] + ifFalse: [self setNextFreeChunkOf: prev withValue: next isLilliputianSize: false.]. + self freeChunkWithBytes: index * self allocationUnit - chunkBytes + at: (self startOfObject: node) + chunkBytes. + ^node]. + prev := node. + node := next]]]]. + "now get desperate and use the first that'll fit. + Note that because the minimum free size is 16 bytes (2 * allocationUnit), to + leave room for the forwarding pointer/next free link, we can only break chunks + that are at least 16 bytes larger, hence start at initialIndex + 2." + index := initialIndex + 1. + [(index := index + 1) < self numFreeLists + and: [1 << index <= manager freeListsMask]] whileTrue: + [(manager freeListsMask anyMask: 1 << index) ifTrue: + [(node := manager freeLists at: index) = 0 + ifTrue: [manager freeListsMask: manager freeListsMask - (1 << index)] + ifFalse: + [prev := 0. + [node ~= 0] whileTrue: + [self assert: node = (self startOfObject: node). + self assertValidFreeObject: node. + next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. + (acceptanceBlock value: node) ifTrue: + [prev = 0 + ifTrue: [self unlinkFreeChunk: node atIndex: index isLilliputianSize: false.] + ifFalse: [self setNextFreeChunkOf: prev withValue: next isLilliputianSize: false.]. + self freeChunkWithBytes: index * self allocationUnit - chunkBytes + at: (self startOfObject: node) + chunkBytes. + ^node]. + prev := node. + node := next]]]]]. + + "Large chunk, or no space on small free lists. Search the large chunk list. + Large chunk list organized as a tree, each node of which is a list of chunks + of the same size. Beneath the node are smaller and larger blocks. + When the search ends parent should hold the smallest chunk at least as + large as chunkBytes, or 0 if none. acceptedChunk and acceptedNode save + us from having to back-up when the acceptanceBlock filters-out all nodes + of the right size, but there are nodes of the wrong size it does accept." + child := manager freeLists at: 0. + node := acceptedChunk := acceptedNode := 0. + [child ~= 0] whileTrue: + [ self assertValidFreeObject: child. + childBytes := self bytesInBody: child. + childBytes = chunkBytes ifTrue: "size match; try to remove from list at node." + [node := child. + [prev := node. + node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. + node ~= 0] whileTrue: + [(acceptanceBlock value: node) ifTrue: + [self assertValidFreeObject: node. + self + setNextFreeChunkOf: prev + withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) + isLilliputianSize: false. + ^self startOfObject: node]]. + (acceptanceBlock value: child) ifTrue: + [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. + next = 0 + ifTrue: "no list; remove the interior node" + [self unlinkSolitaryFreeTreeNode: child] + ifFalse: "list; replace node with it" + [self inFreeTreeReplace: child with: next]. + ^self startOfObject: child]]. + child ~= 0 ifTrue: + ["Note that because the minimum free size is 16 bytes (2 * allocationUnit), to + leave room for the forwarding pointer/next free link, we can only break chunks + that are at least 16 bytes larger, hence reject chunks < 2 * allocationUnit larger." + childBytes <= (chunkBytes + self allocationUnit) + ifTrue: "node too small; walk down the larger size of the tree" + [child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child] + ifFalse: + [self flag: 'we can do better here; preferentially choosing the lowest node. That would be a form of best-fit since we are trying to compact down'. + node := child. + child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: node. + acceptedNode = 0 ifTrue: + [acceptedChunk := node. + "first search the list." + [acceptedChunk := self fetchPointer: self freeChunkNextIndex + ofFreeChunk: acceptedChunk. + (acceptedChunk ~= 0 and: [acceptanceBlock value: acceptedChunk]) ifTrue: + [acceptedNode := node]. + acceptedChunk ~= 0 and: [acceptedNode = 0]] whileTrue. + "nothing on the list; will the node do? This prefers + acceptable nodes higher up the tree over acceptable + list elements further down, but we haven't got all day..." + (acceptedNode = 0 + and: [acceptanceBlock value: node]) ifTrue: + [acceptedNode := node. + child := 0 "break out of loop now we have an acceptedNode"]]]]]. + + acceptedNode ~= 0 ifTrue: + [acceptedChunk ~= 0 ifTrue: + [self assert: (self bytesInBody: acceptedChunk) >= (chunkBytes + self allocationUnit). + [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedNode. + next ~= acceptedChunk] whileTrue: + [acceptedNode := next]. + self + setNextFreeChunkOf: acceptedNode + withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedChunk) + isLilliputianSize: false. + self freeChunkWithBytes: (self bytesInBody: acceptedChunk) - chunkBytes + at: (self startOfObject: acceptedChunk) + chunkBytes. + ^self startOfObject: acceptedChunk]. + next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedNode. + next = 0 + ifTrue: "no list; remove the interior node" + [self unlinkSolitaryFreeTreeNode: acceptedNode] + ifFalse: "list; replace node with it" + [self inFreeTreeReplace: acceptedNode with: next]. + self assert: (self bytesInBody: acceptedNode) >= (chunkBytes + self allocationUnit). + self freeChunkWithBytes: (self bytesInBody: acceptedNode) - chunkBytes + at: (self startOfObject: acceptedNode) + chunkBytes. + ^self startOfObject: acceptedNode]. + + manager totalFreeOldSpace: manager totalFreeOldSpace + chunkBytes. "optimism was unfounded" + ^nil! Item was added: + ----- Method: FreeChunkManager>>assertInnerValidFreeObject: (in category 'as yet unclassified') ----- + assertInnerValidFreeObject: objOop + <inline: #never> "we don't want to inline so we can nest that in an assertion with the return true so the production VM does not generate any code here, while in simulation, the code breaks on the assertion we want to." + | chunk index | + self assert: (self oop: (self addressAfter: objOop) isLessThanOrEqualTo: manager endOfMemory). + chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: objOop. + self assert: (chunk = 0 or: [self isFreeOop: chunk]). + (self isLilliputianSize: (self bytesInBody: objOop)) ifFalse: + ["double linkedlist assertions" + chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: objOop. + chunk = 0 ifFalse: + [self assert: (self isFreeOop: chunk). + self assert: objOop = (self fetchPointer: self freeChunkPrevIndex ofFreeChunk: chunk)]. + chunk := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: objOop. + index := (self bytesInBody: objOop) / self allocationUnit. + (index < self numFreeLists and: [1 << index <= manager freeListsMask]) + ifTrue: + [(manager freeLists at: index) = objOop ifTrue: [self assert: chunk = 0]] + ifFalse: + [self freeTreeNodesDo: [:freeNode | + freeNode = objOop ifTrue: [self assert: chunk = 0]. freeNode]]. + chunk = 0 ifFalse: + [self assert: (self isFreeOop: chunk). + self assert: objOop = (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk)]]. + (self isLargeFreeObject: objOop) ifTrue: + ["Tree assertions" + chunk := self fetchPointer: self freeChunkParentIndex ofFreeChunk: objOop. + self assert: (chunk = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]). + chunk := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: objOop. + self assert: (chunk = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]). + chunk := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: objOop. + self assert: (chunk = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]])]. + ^ true! Item was added: + ----- Method: FreeChunkManager>>detachFreeObject: (in category 'as yet unclassified') ----- + detachFreeObject: freeChunk + <inline: true> + | chunkBytes | + chunkBytes := self bytesInBody: freeChunk. + manager totalFreeOldSpace: manager totalFreeOldSpace - chunkBytes. + self unlinkFreeChunk: freeChunk chunkBytes: chunkBytes! Item was added: + ----- Method: FreeChunkManager>>findLargestFreeChunk (in category 'as yet unclassified') ----- + findLargestFreeChunk + "Answer, but do not remove, the largest free chunk in the free lists." + | treeNode childNode | + treeNode := manager freeLists at: 0. + treeNode = 0 ifTrue: + [^nil]. + [self assertValidFreeObject: treeNode. + self assert: (self bytesInBody: treeNode) >= (self numFreeLists * self allocationUnit). + childNode := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: treeNode. + childNode ~= 0] whileTrue: + [treeNode := childNode]. + ^treeNode! Item was added: + ----- Method: FreeChunkManager>>firstLilliputianChunk (in category 'as yet unclassified') ----- + firstLilliputianChunk + + ^ manager freeLists at: self lilliputianChunkIndex! Item was added: + ----- Method: FreeChunkManager>>freeChunkLargerIndex (in category 'chunk & node indices') ----- + freeChunkLargerIndex + "for organizing the tree of large free chunks." + ^4! Item was added: + ----- Method: FreeChunkManager>>freeChunkNextIndex (in category 'chunk & node indices') ----- + freeChunkNextIndex + "for linking objecs on each free list, or, during pigCompact, doubly- + linking the free objects in address order using the xor link hack." + ^0! Item was added: + ----- Method: FreeChunkManager>>freeChunkParentIndex (in category 'chunk & node indices') ----- + freeChunkParentIndex + "for organizing the tree of large free chunks." + ^2! Item was added: + ----- Method: FreeChunkManager>>freeChunkPrevIndex (in category 'chunk & node indices') ----- + freeChunkPrevIndex + "For linking objecs on each free list, doubly-linking the free objects. + Free chunks of size 1 do not have a prev index." + ^1! Item was added: + ----- Method: FreeChunkManager>>freeChunkSmallerIndex (in category 'chunk & node indices') ----- + freeChunkSmallerIndex + "for organizing the tree of large free chunks." + ^3! Item was added: + ----- Method: FreeChunkManager>>freeChunkWithBytes:at: (in category 'as yet unclassified') ----- + freeChunkWithBytes: bytes at: address + <inline: false> + | freeChunk | + self assert: (self isInOldSpace: address). + self assert: (manager segmentManager segmentContainingObj: address) = (manager segmentManager segmentContainingObj: address + bytes). + freeChunk := self initFreeChunkWithBytes: bytes at: address. + self addToFreeList: freeChunk bytes: bytes. + self assert: freeChunk = (self objectStartingAt: address). + ^freeChunk! Item was added: + ----- Method: FreeChunkManager>>freeTreeNodesDo: (in category 'as yet unclassified') ----- + freeTreeNodesDo: aBlock + "Enumerate all nodes in the free tree (in order, smaller to larger), + but *not* including the next nodes of the same size off each tree node. + This is an iterative version so that the block argument can be + inlined by Slang. The trick to an iterative binary tree application is + to apply the function on the way back up when returning from a + particular direction, in this case up from the larger child. + + N.B For the convenience of rebuildFreeTreeFromSortedFreeChunks + aBlock *MUST* answer the freeTreeNode it was invoked with, or + its replacement if it was replaced by aBlock." + <inline: true> + | treeNode cameFrom | + treeNode := manager freeLists at: 0. + treeNode = 0 ifTrue: + [^self]. + cameFrom := -1. + [| smallChild largeChild | + self assert: (self bytesInBody: treeNode) >= (self numFreeLists * self allocationUnit). + smallChild := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: treeNode. + largeChild := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: treeNode. + self assert: (smallChild = 0 or: [treeNode = (self fetchPointer: self freeChunkParentIndex ofFreeChunk: smallChild)]). + self assert: (largeChild = 0 or: [treeNode = (self fetchPointer: self freeChunkParentIndex ofFreeChunk: largeChild)]). + "apply if the node has no children, or it has no large children and we're + returning from the small child, or we're returning from the large child." + ((smallChild = 0 and: [largeChild = 0]) + or: [largeChild = 0 + ifTrue: [cameFrom = smallChild] + ifFalse: [cameFrom = largeChild]]) + ifTrue: + [treeNode := aBlock value: treeNode. + "and since we've applied we must move on up" + cameFrom := treeNode. + treeNode := self fetchPointer: self freeChunkParentIndex ofFreeChunk: treeNode] + ifFalse: + [(smallChild ~= 0 and: [cameFrom ~= smallChild]) + ifTrue: + [treeNode := smallChild] + ifFalse: + [self assert: largeChild ~= 0. + treeNode := largeChild]. + cameFrom := -1]. + treeNode ~= 0] whileTrue! Item was added: + ----- Method: FreeChunkManager>>freeTreeOverlapCheck (in category 'as yet unclassified') ----- + freeTreeOverlapCheck + <doNotGenerate> + "Assumes no 2 consecutive free chunks" + self allObjectsInFreeTreeDo: [:freeNode1| + self allObjectsInFreeTreeDo: [:freeNode2| + freeNode1 == freeNode2 + ifFalse: + [|start1 start2 end1 end2| + start1 := self startOfObject: freeNode1. + start2 := self startOfObject: freeNode2. + end1 := start1 + (self bytesInBody: freeNode1). + end2 := start2 + (self bytesInBody: freeNode2). + " + Transcript + show: '['; show: start1; show: ';'; + show: end1; show: '];'; cr; show: '['; show: start2; + show: ';'; show: end2; show: ']'; cr. + " + self assert: (start2 > end1 or: [end2 < start1]). + self assert: (start1 > end2 or: [start1 < start2])]]]! Item was added: + ----- Method: FreeChunkManager>>inFreeTreeReplace:with: (in category 'as yet unclassified') ----- + inFreeTreeReplace: treeNode with: newNode + "Part of reorderReversedTreeList:. Switch treeNode with newNode in + the tree, but do nothing to the list linked through freeChunkNextIndex." + | relative | + self storePointer: self freeChunkPrevIndex ofFreeChunk: newNode withValue: 0. + "copy parent, smaller, larger" + self freeChunkParentIndex to: self freeChunkLargerIndex do: + [:i| + relative := self fetchPointer: i ofFreeChunk: treeNode. + i = self freeChunkParentIndex + ifTrue: + [relative = 0 + ifTrue: "update root to point to newNode" + [self assert: (manager freeLists at: 0) = treeNode. + manager freeLists at: 0 put: newNode] + ifFalse: "replace link from parent to treeNode with link to newNode." + [self storePointer: (treeNode = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: relative) + ifTrue: [self freeChunkSmallerIndex] + ifFalse: [self freeChunkLargerIndex]) + ofFreeChunk: relative + withValue: newNode]] + ifFalse: + [relative ~= 0 ifTrue: + [self assert: (self fetchPointer: self freeChunkParentIndex ofFreeChunk: relative) = treeNode. + self storePointer: self freeChunkParentIndex ofFreeChunk: relative withValue: newNode]]. + self storePointer: i ofFreeChunk: newNode withValue: relative. + self storePointer: i ofFreeChunk: treeNode withValue: 0]! Item was added: + ----- Method: ImageLeakChecker>>incrementalMarkAndTraceInterpreterOops (in category 'no-op overrides') ----- + incrementalMarkAndTraceInterpreterOops! Item was changed: + ----- Method: InterpreterPrimitives>>primitiveClone (in category 'instantiation primitives') ----- - ----- Method: InterpreterPrimitives>>primitiveClone (in category 'object access primitives') ----- primitiveClone "Return a shallow copy of the receiver." | rcvr newCopy | rcvr := self stackTop. (objectMemory isImmediate: rcvr) ifTrue: [newCopy := rcvr] ifFalse: [(argumentCount = 0 or: [(objectMemory isForwarded: rcvr) not]) ifTrue: [newCopy := objectMemory cloneObject: rcvr] ifFalse: [newCopy := 0]. newCopy = 0 ifTrue: "not enough memory most likely" [^self primitiveFail]]. self pop: argumentCount + 1 thenPush: newCopy! Item was changed: + ----- Method: InterpreterPrimitives>>primitiveNew (in category 'instantiation primitives') ----- - ----- Method: InterpreterPrimitives>>primitiveNew (in category 'object access primitives') ----- primitiveNew NewspeakVM ifTrue: "For the mirror prims check that the class obj is actually a valid class." [(argumentCount < 1 or: [self objCouldBeClassObj: self stackTop]) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]]. objectMemory hasSpurMemoryManagerAPI ifTrue: ["Allocate a new fixed-size instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free. This *will not* cause a GC :-)" (objectMemory instantiateClass: self stackTop) ifNotNil: [:obj| self pop: argumentCount + 1 thenPush: obj] ifNil: [self primitiveFailFor: ((objectMemory isFixedSizePointerFormat: (objectMemory instSpecOfClass: self stackTop)) ifTrue: [PrimErrNoMemory] ifFalse: [PrimErrBadReceiver])]] ifFalse: ["Allocate a new fixed-size instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free. May cause a GC." | spaceOkay | "The following may cause GC!! Use var for result to permit inlining." spaceOkay := objectMemory sufficientSpaceToInstantiate: self stackTop indexableSize: 0. spaceOkay ifTrue: [self pop: argumentCount + 1 thenPush: (objectMemory instantiateClass: self stackTop indexableSize: 0)] ifFalse: [self primitiveFailFor: PrimErrNoMemory]]! Item was changed: + ----- Method: InterpreterPrimitives>>primitiveNewMethod (in category 'instantiation primitives') ----- - ----- Method: InterpreterPrimitives>>primitiveNewMethod (in category 'compiled methods') ----- primitiveNewMethod | header bytecodeCount class size theMethod literalCount | header := self stackTop. bytecodeCount := self stackValue: 1. ((objectMemory isIntegerObject: header) and: [(objectMemory isIntegerObject: bytecodeCount) and: [(bytecodeCount := objectMemory integerValueOf: bytecodeCount) >= 0]]) ifFalse: [self primitiveFailFor: PrimErrBadArgument. ^self]. class := self stackValue: 2. literalCount := objectMemory literalCountOfMethodHeader: header. size := literalCount + LiteralStart * objectMemory bytesPerOop + bytecodeCount. objectMemory hasSpurMemoryManagerAPI ifTrue: [theMethod := objectMemory instantiateCompiledMethodClass: class indexableSize: size. theMethod ifNil: [self primitiveFailFor: ((objectMemory isCompiledMethodFormat: (objectMemory instSpecOfClass: class)) ifTrue: [PrimErrNoMemory] ifFalse: [PrimErrBadReceiver]). ^self]] ifFalse: [theMethod := objectMemory instantiateClass: class indexableSize: size]. objectMemory storePointerUnchecked: HeaderIndex ofObject: theMethod withValue: header. 1 to: literalCount do: [:i | objectMemory storePointerUnchecked: i ofObject: theMethod withValue: objectMemory nilObject]. self pop: 3 thenPush: theMethod! Item was added: + ----- Method: InterpreterPrimitives>>primitiveNewPinnedInOldSpace (in category 'object access primitives') ----- + primitiveNewPinnedInOldSpace + NewspeakVM ifTrue: "For the mirror prims check that the class obj is actually a valid class." + [(argumentCount < 1 + or: [self objCouldBeClassObj: self stackTop]) ifFalse: + [^self primitiveFailFor: PrimErrBadArgument]]. + objectMemory hasSpurMemoryManagerAPI + ifTrue: + ["Allocate a new fixed-size instance. Fail if the allocation would leave + less than lowSpaceThreshold bytes free. This *will not* cause a GC :-)" + (objectMemory instantiateClass: self stackTop) + ifNotNil: [:obj| self pop: argumentCount + 1 thenPush: obj] + ifNil: [self primitiveFailFor: ((objectMemory isFixedSizePointerFormat: (objectMemory instSpecOfClass: self stackTop)) + ifTrue: [PrimErrNoMemory] + ifFalse: [PrimErrBadReceiver])]] + ifFalse: + ["Allocate a new fixed-size instance. Fail if the allocation would leave + less than lowSpaceThreshold bytes free. May cause a GC." + | spaceOkay | + "The following may cause GC!! Use var for result to permit inlining." + spaceOkay := objectMemory + sufficientSpaceToInstantiate: self stackTop + indexableSize: 0. + spaceOkay + ifTrue: + [self + pop: argumentCount + 1 + thenPush: (objectMemory + instantiateClass: self stackTop + indexableSize: 0)] + ifFalse: [self primitiveFailFor: PrimErrNoMemory]]! Item was changed: + ----- Method: InterpreterPrimitives>>primitiveNewWithArg (in category 'instantiation primitives') ----- - ----- Method: InterpreterPrimitives>>primitiveNewWithArg (in category 'object access primitives') ----- primitiveNewWithArg "Allocate a new indexable instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free. May cause a GC." | size spaceOkay instSpec | NewspeakVM ifTrue: "For the mirror prims check that the class obj is actually a valid class." [(argumentCount < 2 or: [self addressCouldBeClassObj: (self stackValue: 1)]) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]]. size := self positiveMachineIntegerValueOf: self stackTop. self successful ifFalse:"positiveMachineIntegerValueOf: succeeds only for non-negative integers." [^self primitiveFailFor: PrimErrBadArgument]. objectMemory hasSpurMemoryManagerAPI ifTrue: [(objectMemory instantiateClass: (self stackValue: 1) indexableSize: size) ifNotNil: [:obj| self pop: argumentCount + 1 thenPush: obj] ifNil: [instSpec := objectMemory instSpecOfClass: (self stackValue: 1). self primitiveFailFor: (((objectMemory isIndexableFormat: instSpec) and: [(objectMemory isCompiledMethodFormat: instSpec) not]) ifTrue: [PrimErrNoMemory] ifFalse: [PrimErrBadReceiver])]] ifFalse: [spaceOkay := objectMemory sufficientSpaceToInstantiate: (self stackValue: 1) indexableSize: size. spaceOkay ifTrue: [self pop: argumentCount + 1 thenPush: (objectMemory instantiateClass: (self stackValue: 1) indexableSize: size)] ifFalse: [self primitiveFailFor: PrimErrNoMemory]]! Item was added: + ----- Method: InterpreterPrimitives>>primitiveNewWithArgUninitialized (in category 'object access primitives') ----- + primitiveNewWithArgUninitialized + "Allocate a new indexable instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free. May cause a GC." + | size spaceOkay instSpec | + NewspeakVM ifTrue: "For the mirror prims check that the class obj is actually a valid class." + [(argumentCount < 2 + or: [self addressCouldBeClassObj: (self stackValue: 1)]) ifFalse: + [^self primitiveFailFor: PrimErrBadArgument]]. + size := self positiveMachineIntegerValueOf: self stackTop. + self successful ifFalse:"positiveMachineIntegerValueOf: succeeds only for non-negative integers." + [^self primitiveFailFor: PrimErrBadArgument]. + objectMemory hasSpurMemoryManagerAPI + ifTrue: + [(objectMemory instantiateUninitializedClass: (self stackValue: 1) indexableSize: size) + ifNotNil: [:obj| self pop: argumentCount + 1 thenPush: obj] + ifNil: [instSpec := objectMemory instSpecOfClass: (self stackValue: 1). + self primitiveFailFor: (((objectMemory isIndexableFormat: instSpec) + and: [(objectMemory isCompiledMethodFormat: instSpec) not]) + ifTrue: [PrimErrNoMemory] + ifFalse: [PrimErrBadReceiver])]] + ifFalse: + [spaceOkay := objectMemory sufficientSpaceToInstantiate: (self stackValue: 1) indexableSize: size. + spaceOkay + ifTrue: + [self + pop: argumentCount + 1 + thenPush: (objectMemory instantiateClass: (self stackValue: 1) indexableSize: size)] + ifFalse: + [self primitiveFailFor: PrimErrNoMemory]]! Item was changed: + ----- Method: InterpreterPrimitives>>primitivePinnedNew (in category 'instantiation primitives') ----- - ----- Method: InterpreterPrimitives>>primitivePinnedNew (in category 'object access primitives') ----- primitivePinnedNew NewspeakVM ifTrue: "For the mirror prims check that the class obj is actually a valid class." [(argumentCount < 1 or: [self objCouldBeClassObj: self stackTop]) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]]. objectMemory hasSpurMemoryManagerAPI ifTrue: ["Allocate a new fixed-size instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free. This *will not* cause a GC :-)" (objectMemory inOldSpaceInstantiatePinnedClass: self stackTop) ifNotNil: [:obj| self pop: argumentCount + 1 thenPush: obj] ifNil: [self primitiveFailFor: ((objectMemory isFixedSizePointerFormat: (objectMemory instSpecOfClass: self stackTop)) ifTrue: [PrimErrNoMemory] ifFalse: [PrimErrBadReceiver])]] ifFalse: [self primitiveFailFor: PrimErrUnsupported]! Item was changed: + ----- Method: InterpreterPrimitives>>primitivePinnedNewWithArg (in category 'instantiation primitives') ----- - ----- Method: InterpreterPrimitives>>primitivePinnedNewWithArg (in category 'object access primitives') ----- primitivePinnedNewWithArg "Allocate a new pinned indexable instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free." | size instSpec | NewspeakVM ifTrue: "For the mirror prims check that the class obj is actually a valid class." [(argumentCount < 2 or: [self addressCouldBeClassObj: (self stackValue: 1)]) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]]. size := self positiveMachineIntegerValueOf: self stackTop. self successful ifFalse:"positiveMachineIntegerValueOf: succeeds only for non-negative integers." [^self primitiveFailFor: PrimErrBadArgument]. objectMemory hasSpurMemoryManagerAPI ifTrue: [(objectMemory inOldSpaceInstantiatePinnedClass: (self stackValue: 1) indexableSize: size) ifNotNil: [:obj| self pop: argumentCount + 1 thenPush: obj] ifNil: [instSpec := objectMemory instSpecOfClass: (self stackValue: 1). self primitiveFailFor: (((objectMemory isIndexableFormat: instSpec) and: [(objectMemory isCompiledMethodFormat: instSpec) not]) ifTrue: [PrimErrNoMemory] ifFalse: [PrimErrBadReceiver])]] ifFalse: [self primitiveFailFor: PrimErrUnsupported]! Item was changed: + ----- Method: InterpreterPrimitives>>primitiveUninitializedNewWithArg (in category 'instantiation primitives') ----- - ----- Method: InterpreterPrimitives>>primitiveUninitializedNewWithArg (in category 'object access primitives') ----- primitiveUninitializedNewWithArg "Allocate a new indexable instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free. May cause a GC." | size instSpec | NewspeakVM ifTrue: "For the mirror prims check that the class obj is actually a valid class." [(argumentCount < 2 or: [self addressCouldBeClassObj: (self stackValue: 1)]) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]]. size := self positiveMachineIntegerValueOf: self stackTop. self successful ifFalse:"positiveMachineIntegerValueOf: succeeds only for non-negative integers." [^self primitiveFailFor: PrimErrBadArgument]. objectMemory hasSpurMemoryManagerAPI ifTrue: [(objectMemory instantiateUninitializedClass: (self stackValue: 1) indexableSize: size) ifNotNil: [:obj| self pop: argumentCount + 1 thenPush: obj] ifNil: [instSpec := objectMemory instSpecOfClass: (self stackValue: 1). self primitiveFailFor: (((objectMemory isIndexableFormat: instSpec) and: [(objectMemory isCompiledMethodFormat: instSpec) not]) ifTrue: [PrimErrNoMemory] ifFalse: [PrimErrBadReceiver])]] ifFalse: [self primitiveFailFor: PrimErrUnsupported]! Item was removed: - ----- Method: Spur32BitMMLECoSimulator>>globalGarbageCollect (in category 'gc - global') ----- - globalGarbageCollect - "If we're /not/ a clone, clone the VM and push it over the cliff. - If it survives, destroy the clone and continue. We should be OK until next time." - parent ifNil: - [coInterpreter cr; print: 'GC number '; printNum: statFullGCs; tab; flush. - CloneOnGC ifTrue: - [coInterpreter cloneSimulation objectMemory globalGarbageCollect. - Smalltalk garbageCollect]]. - ^super globalGarbageCollect! Item was added: + ----- Method: Spur32BitMMLECoSimulator>>preGlobalGCActions (in category 'gc - global') ----- + preGlobalGCActions + "If we're /not/ a clone, clone the VM and push it over the cliff. + If it survives, destroy the clone and continue. We should be OK until next time." + parent ifNil: + [coInterpreter cr; print: 'GC number '; printNum: statFullGCs; tab; flush. + CloneOnGC ifTrue: + [coInterpreter cloneSimulation objectMemory gc globalGarbageCollect. + Smalltalk garbageCollect]]! Item was removed: - ----- Method: Spur32BitMMLESimulator>>globalGarbageCollect (in category 'gc - global') ----- - globalGarbageCollect - "If we're /not/ a clone, clone the VM and push it over the cliff. - If it survives, destroy the clone and continue. We should be OK until next time." - parent ifNil: - [coInterpreter cr; print: 'GC number '; printNum: statFullGCs; tab; flush. - CloneOnGC ifTrue: - [coInterpreter cloneSimulation objectMemory globalGarbageCollect. - Smalltalk garbageCollect]]. - ^super globalGarbageCollect! Item was added: + ----- Method: Spur32BitMMLESimulator>>preGlobalGCActions (in category 'gc - global') ----- + preGlobalGCActions + "If we're /not/ a clone, clone the VM and push it over the cliff. + If it survives, destroy the clone and continue. We should be OK until next time." + parent ifNil: + [coInterpreter cr; print: 'GC number '; printNum: statFullGCs; tab; flush. + CloneOnGC ifTrue: + [coInterpreter cloneSimulation objectMemory gc globalGarbageCollect. + Smalltalk garbageCollect]]! Item was changed: ----- Method: Spur32BitMemoryManager>>allocateSlotsForPinningInOldSpace:bytes:format:classIndex: (in category 'allocation') ----- allocateSlotsForPinningInOldSpace: numSlots bytes: totalBytes format: formatField classIndex: classIndex "Answer the oop of a chunk of space in oldSpace with numSlots slots. Try and allocate in a segment that already includes pinned objects. The header of the result will have been filled-in but not the contents." <var: #totalBytes type: #usqInt> <inline: false> | chunk | chunk := self allocateOldSpaceChunkOfBytes: totalBytes suchThat: [:f| (segmentManager segmentContainingObj: f) containsPinned]. chunk ifNil: [chunk := self allocateOldSpaceChunkOfBytes: totalBytes. chunk ifNil: [^nil]. (segmentManager segmentContainingObj: chunk) containsPinned: true]. numSlots >= self numSlotsMask ifTrue: "for header parsing we put a saturated slot count in the prepended overflow size word" [self flag: #endianness. self longAt: chunk put: numSlots. self longAt: chunk + 4 put: self numSlotsMask << self numSlotsHalfShift. self long64At: chunk + self baseHeaderSize put: ((self headerForSlots: self numSlotsMask format: formatField classIndex: classIndex) bitOr: 1 << self pinnedBitShift). + + self flag: #Todo. "later on we probably want to do this in the call above" + gc maybeModifyGCFlagsOf: chunk + self baseHeaderSize. self checkFreeSpace: GCModeNewSpace. ^chunk + self baseHeaderSize]. self long64At: chunk put: ((self headerForSlots: numSlots format: formatField classIndex: classIndex) bitOr: 1 << self pinnedBitShift). + + self flag: #Todo. "later on we probably want to do this in the call above" + gc maybeModifyGCFlagsOf: chunk. self checkFreeSpace: GCModeNewSpace. ^chunk! Item was changed: ----- Method: Spur32BitMemoryManager>>allocateSlotsInOldSpace:bytes:format:classIndex: (in category 'allocation') ----- allocateSlotsInOldSpace: numSlots bytes: totalBytes format: formatField classIndex: classIndex "Answer the oop of a chunk of space in oldSpace with numSlots slots. The header will have been filled-in but not the contents. If no memory is available answer nil." <var: #totalBytes type: #usqInt> <inline: false> | chunk | chunk := self allocateOldSpaceChunkOfBytes: totalBytes. chunk ifNil: [^nil]. numSlots >= self numSlotsMask ifTrue: "for header parsing we put a saturated slot count in the prepended overflow size word" [self flag: #endianness. self longAt: chunk put: numSlots. self longAt: chunk + 4 put: self numSlotsMask << self numSlotsHalfShift. self long64At: chunk + self baseHeaderSize put: (self headerForSlots: self numSlotsMask format: formatField classIndex: classIndex). + + self flag: #Todo. "later on we probably want to do this in the call above" + gc maybeModifyGCFlagsOf: chunk + self baseHeaderSize. self checkFreeSpace: GCModeNewSpace. ^chunk + self baseHeaderSize]. self long64At: chunk put: (self headerForSlots: numSlots format: formatField classIndex: classIndex). + + self flag: #Todo. "later on we probably want to do this in the call above" + gc maybeModifyGCFlagsOf: chunk. self checkFreeSpace: GCModeNewSpace. ^chunk! Item was changed: ----- Method: Spur32BitMemoryManager>>setIsGreyOf:to: (in category 'header access') ----- setIsGreyOf: objOop to: aBoolean + + gc assertSettingGCFlagsIsOk: objOop. + self flag: #endianness. self longAt: objOop put: (aBoolean ifTrue: [(self longAt: objOop) bitOr: 1 << self greyBitShift] ifFalse: [(self longAt: objOop) bitAnd: (1 << self greyBitShift) bitInvert32])! Item was changed: ----- Method: Spur32BitMemoryManager>>setIsMarkedOf:to: (in category 'header access') ----- setIsMarkedOf: objOop to: aBoolean self assert: (self isFreeObject: objOop) not. + gc assertSettingGCFlagsIsOk: objOop. + self flag: #endianness. self longAt: objOop + 4 put: (aBoolean ifTrue: [(self longAt: objOop + 4) bitOr: 1 << self markedBitHalfShift] ifFalse: [(self longAt: objOop + 4) bitAnd: (1 << self markedBitHalfShift) bitInvert32])! Item was added: + ----- Method: Spur32BitMemoryManager>>uncheckedSetIsMarkedOf:to: (in category 'header access') ----- + uncheckedSetIsMarkedOf: objOop to: aBoolean + + self assert: (self isFreeObject: objOop) not. + + self flag: #endianness. + self longAt: objOop + 4 + put: (aBoolean + ifTrue: [(self longAt: objOop + 4) bitOr: 1 << self markedBitHalfShift] + ifFalse: [(self longAt: objOop + 4) bitAnd: (1 << self markedBitHalfShift) bitInvert32])! Item was changed: ----- Method: Spur64BitMMLECoSimulator>>coInterpreter:cogit: (in category 'initialization') ----- coInterpreter: aCoInterpreter cogit: aCogit + coInterpreter := aCoInterpreter. cogit := aCogit. + marker coInterpreter: aCoInterpreter. scavenger coInterpreter: aCoInterpreter. + compactor coInterpreter: aCoInterpreter. + gc coInterpreter: aCoInterpreter + ! - compactor coInterpreter: aCoInterpreter! Item was removed: - ----- Method: Spur64BitMMLECoSimulator>>globalGarbageCollect (in category 'gc - global') ----- - globalGarbageCollect - "If we're /not/ a clone, clone the VM and push it over the cliff. - If it survives, destroy the clone and continue. We should be OK until next time." - parent ifNil: - [coInterpreter cr; print: 'GC number '; printNum: statFullGCs; tab; flush. - CloneOnGC ifTrue: - [coInterpreter cloneSimulation objectMemory globalGarbageCollect. - Smalltalk garbageCollect]]. - ^super globalGarbageCollect! Item was added: + ----- Method: Spur64BitMMLECoSimulator>>preGlobalGCActions (in category 'gc - global') ----- + preGlobalGCActions + "If we're /not/ a clone, clone the VM and push it over the cliff. + If it survives, destroy the clone and continue. We should be OK until next time." + parent ifNil: + [coInterpreter cr; print: 'GC number '; printNum: statFullGCs; tab; flush. + CloneOnGC ifTrue: + [coInterpreter cloneSimulation objectMemory gc globalGarbageCollect. + Smalltalk garbageCollect]]! Item was removed: - ----- Method: Spur64BitMMLESimulator>>globalGarbageCollect (in category 'gc - global') ----- - globalGarbageCollect - "If we're /not/ a clone, clone the VM and push it over the cliff. - If it survives, destroy the clone and continue. We should be OK until next time." - parent ifNil: - [coInterpreter cr; print: 'GC number '; printNum: statFullGCs; tab; flush. - CloneOnGC ifTrue: - [coInterpreter cloneSimulation objectMemory globalGarbageCollect. - Smalltalk garbageCollect]]. - ^super globalGarbageCollect! Item was changed: ----- Method: Spur64BitMMLESimulator>>longAt:put: (in category 'memory access') ----- longAt: byteAddress put: a64BitValue "Store the 64-bit value at byteAddress which must be 0 mod 8." + "(self statScavenges >= 120 and: [byteAddress = 16rC7F770]) ifTrue: [self halt]." + "(self statScavenges >= 320 and: [byteAddress = 16r30DF6D0]) ifTrue: [self halt]." + "(self statScavenges >= 320 and: [a64BitValue = 16r30DF6D0]) ifTrue: [self halt]." + "byteAddress = 16r4A00408 ifTrue: [self halt]. + a64BitValue = 16r5A00408 ifTrue: [self halt]." - "byteAddress = 16r43C790 ifTrue: [self halt]." ^self long64At: byteAddress put: a64BitValue! Item was added: + ----- Method: Spur64BitMMLESimulator>>preGlobalGCActions (in category 'gc - global') ----- + preGlobalGCActions + "If we're /not/ a clone, clone the VM and push it over the cliff. + If it survives, destroy the clone and continue. We should be OK until next time." + parent ifNil: + [coInterpreter cr; print: 'GC number '; printNum: statFullGCs; tab; flush. + CloneOnGC ifTrue: + [coInterpreter cloneSimulation objectMemory gc globalGarbageCollect. + Smalltalk garbageCollect]]! Item was changed: ----- Method: Spur64BitMMLESimulator>>scavengingGCTenuringIf: (in category 'gc - global') ----- scavengingGCTenuringIf: tenuringCriterion "If we're /not/ a clone, clone the VM and push it over the cliff. If it survives, destroy the clone and continue. We should be OK until next time." + self setCheckForLeaks: GCModeFull. (self leakCheckNewSpaceGC and: [parent isNil]) ifTrue: [coInterpreter cr; print: 'scavenge '; print: statScavenges; tab; flush. CloneOnScavenge ifTrue: [coInterpreter cloneSimulation objectMemory scavengingGCTenuringIf: tenuringCriterion. Smalltalk garbageCollect]]. ^super scavengingGCTenuringIf: tenuringCriterion! Item was added: + ----- Method: Spur64BitMMLESimulator>>setIsGreyOf:to: (in category 'header access') ----- + setIsGreyOf: objOop to: aBoolean + "objOop = 16rB26020 ifTrue: [self halt]." + "(#(16r1971D0 16r196EE0 16r197048 16r197148) includes: objOop) ifTrue: + [self halt]." + "GCEventLog register: ((aBoolean + ifTrue: [GCGreyEvent] + ifFalse: [GCUngreyEvent]) address: objOop)." + + super setIsGreyOf: objOop to: aBoolean. + "(aBoolean + and: [(self isContextNonImm: objOop) + and: [(coInterpreter + checkIsStillMarriedContext: objOop + currentFP: coInterpreter framePointer) + and: [(coInterpreter stackPages stackPageFor: (coInterpreter frameOfMarriedContext: objOop)) trace = 0]]]) ifTrue: + [self halt]"! Item was changed: ----- Method: Spur64BitMMLESimulator>>setIsMarkedOf:to: (in category 'header access') ----- setIsMarkedOf: objOop to: aBoolean "objOop = 16rB26020 ifTrue: [self halt]." "(#(16r1971D0 16r196EE0 16r197048 16r197148) includes: objOop) ifTrue: [self halt]." + "GCEventLog register: ((aBoolean + ifTrue: [GCMarkEvent] + ifFalse: [GCUnmarkEvent]) address: objOop)." + super setIsMarkedOf: objOop to: aBoolean. "(aBoolean and: [(self isContextNonImm: objOop) and: [(coInterpreter checkIsStillMarriedContext: objOop currentFP: coInterpreter framePointer) and: [(coInterpreter stackPages stackPageFor: (coInterpreter frameOfMarriedContext: objOop)) trace = 0]]]) ifTrue: [self halt]"! Item was added: + ----- Method: Spur64BitMMLESimulator>>unlinkFreeChunk:chunkBytes: (in category 'as yet unclassified') ----- + unlinkFreeChunk: freeChunk chunkBytes: chunkBytes + + "GCEventLog register: (GCUnlinkEvent address: freeChunk)." + ^ super unlinkFreeChunk: freeChunk chunkBytes: chunkBytes! Item was changed: ----- Method: Spur64BitMemoryManager>>allocateSlotsForPinningInOldSpace:bytes:format:classIndex: (in category 'allocation') ----- allocateSlotsForPinningInOldSpace: numSlots bytes: totalBytes format: formatField classIndex: classIndex "Answer the oop of a chunk of space in oldSpace with numSlots slots. Try and allocate in a segment that already includes pinned objects. The header of the result will have been filled-in but not the contents." <var: #totalBytes type: #usqInt> <inline: false> | chunk | chunk := self allocateOldSpaceChunkOfBytes: totalBytes suchThat: [:f| (segmentManager segmentContainingObj: f) containsPinned]. chunk ifNil: [chunk := self allocateOldSpaceChunkOfBytes: totalBytes. chunk ifNil: [^nil]. (segmentManager segmentContainingObj: chunk) containsPinned: true]. numSlots >= self numSlotsMask ifTrue: "for header parsing we put a saturated slot count in the prepended overflow size word" [self longAt: chunk put: numSlots + (self numSlotsMask << self numSlotsFullShift). self longAt: chunk + self baseHeaderSize put: ((self headerForSlots: self numSlotsMask format: formatField classIndex: classIndex) bitOr: 1 << self pinnedBitShift). + + self flag: #Todo. "later on we probably want to do this in the call above" + gc maybeModifyGCFlagsOf: chunk + self baseHeaderSize. self checkFreeSpace: GCModeNewSpace. ^chunk + self baseHeaderSize]. self longAt: chunk put: ((self headerForSlots: numSlots format: formatField classIndex: classIndex) bitOr: 1 << self pinnedBitShift). + + self flag: #Todo. "later on we probably want to do this in the call above" + gc maybeModifyGCFlagsOf: chunk. self checkFreeSpace: GCModeNewSpace. ^chunk! Item was changed: ----- Method: Spur64BitMemoryManager>>allocateSlotsInOldSpace:bytes:format:classIndex: (in category 'allocation') ----- allocateSlotsInOldSpace: numSlots bytes: totalBytes format: formatField classIndex: classIndex "Answer the oop of a chunk of space in oldSpace with numSlots slots. The header will have been filled-in but not the contents. If no memory is available answer nil." <var: #totalBytes type: #usqInt> <inline: false> | chunk | chunk := self allocateOldSpaceChunkOfBytes: totalBytes. chunk ifNil: [^nil]. numSlots >= self numSlotsMask ifTrue: "for header parsing we put a saturated slot count in the prepended overflow size word" [self longAt: chunk put: numSlots + (self numSlotsMask << self numSlotsFullShift). self longAt: chunk + self baseHeaderSize put: (self headerForSlots: self numSlotsMask format: formatField classIndex: classIndex). + + self flag: #Todo. "later on we probably want to do this in the call above" + gc maybeModifyGCFlagsOf: chunk + self baseHeaderSize. self checkFreeSpace: GCModeNewSpace ignoring: chunk + self baseHeaderSize. ^chunk + self baseHeaderSize]. self longAt: chunk put: (self headerForSlots: numSlots format: formatField classIndex: classIndex). + + self flag: #Todo. "later on we probably want to do this in the call above" + gc maybeModifyGCFlagsOf: chunk. self checkFreeSpace: GCModeNewSpace ignoring: chunk. ^chunk! Item was changed: ----- Method: Spur64BitMemoryManager>>setIsGreyOf:to: (in category 'header access') ----- setIsGreyOf: objOop to: aBoolean + + gc assertSettingGCFlagsIsOk: objOop. + self longAt: objOop put: (aBoolean ifTrue: [(self longAt: objOop) bitOr: 1 << self greyBitShift] ifFalse: [(self longAt: objOop) bitAnd: (1 << self greyBitShift) bitInvert64])! Item was changed: ----- Method: Spur64BitMemoryManager>>setIsMarkedOf:to: (in category 'header access') ----- setIsMarkedOf: objOop to: aBoolean self assert: (self isFreeObject: objOop) not. + "gc assertSettingGCFlagsIsOk: objOop." self longAt: objOop put: (aBoolean ifTrue: [(self longAt: objOop) bitOr: 1 << self markedBitFullShift] ifFalse: [(self longAt: objOop) bitAnd: (1 << self markedBitFullShift) bitInvert64])! Item was added: + ----- Method: Spur64BitMemoryManager>>uncheckedSetIsMarkedOf:to: (in category 'header access') ----- + uncheckedSetIsMarkedOf: objOop to: aBoolean + self assert: (self isFreeObject: objOop) not. + + self longAt: objOop + put: (aBoolean + ifTrue: [(self longAt: objOop) bitOr: 1 << self markedBitFullShift] + ifFalse: [(self longAt: objOop) bitAnd: (1 << self markedBitFullShift) bitInvert64])! Item was added: + SpurMarker subclass: #SpurAllAtOnceMarker + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'VMMaker-SpurGarbageCollector'! Item was added: + ----- Method: SpurAllAtOnceMarker class>>implicitReturnTypeFor: (in category 'translation') ----- + implicitReturnTypeFor: aSelector + "Answer the return type for methods that don't have an explicit return." + ^#void! Item was added: + ----- Method: SpurAllAtOnceMarker class>>simulatorClass (in category 'simulation') ----- + simulatorClass + ^ SpurAllAtOnceMarkerSimulator! Item was added: + ----- Method: SpurAllAtOnceMarker class>>sourceSortingKey (in category 'translation') ----- + sourceSortingKey + "To keep methods in the same order while refactoring..." + ^SpurMemoryManager name! Item was added: + ----- Method: SpurAllAtOnceMarker>>markAccessibleObjectsAndFireEphemerons (in category 'marking') ----- + markAccessibleObjectsAndFireEphemerons + self assert: marking. + self assert: manager validClassTableRootPages. + self assert: manager segmentManager allBridgesMarked. + self cCode: [] "for debugging markAndTrace: set (MarkStackRecord := OrderedCollection new)" + inSmalltalk: [MarkStackRecord ifNotNil: [MarkStackRecord resetTo: 1]]. + + "This must come first to enable stack page reclamation. It clears + the trace flags on stack pages and so must precede any marking. + Otherwise it will clear the trace flags of reached pages." + coInterpreter initStackPageGC. + self markAndTraceHiddenRoots. + self markAndTraceExtraRoots. + self assert: manager validClassTableRootPages. + coInterpreter markAndTraceInterpreterOops: true. + self assert: manager validObjStacks. + self markWeaklingsAndMarkAndFireEphemerons. + self assert: manager validObjStacks! Item was added: + ----- Method: SpurAllAtOnceMarker>>markAllUnscannedEphemerons (in category 'weakness and ephemerality') ----- + markAllUnscannedEphemerons + "After firing the unscanned ephemerons we must scan-mark them. + The wrinkle is that doing so may add more ephemerons to the set. + So we remove the first element, by overwriting it with the last element, + and decrementing the top, and then markAndTrace its contents." + self assert: (manager noUnscannedEphemerons) not. + self assert: manager allUnscannedEphemeronsAreActive. + [manager unscannedEphemerons top > manager unscannedEphemerons start] whileTrue: + [| ephemeron key lastptr | + ephemeron := manager longAt: manager unscannedEphemerons start. + lastptr := manager unscannedEphemerons top - manager bytesPerOop. + lastptr > manager unscannedEphemerons start ifTrue: + [manager longAt: manager unscannedEphemerons start put: (manager longAt: lastptr)]. + manager unscannedEphemerons top: lastptr. + key := manager followedKeyOfMaybeFiredEphemeron: ephemeron. + manager setIsMarkedOf: ephemeron to: false. "to get it to be fully scanned in markAndTrace:" + self + markAndTrace: key; + markAndTrace: ephemeron]! Item was added: + ----- Method: SpurAllAtOnceMarker>>markAndShouldScan: (in category 'marking') ----- + markAndShouldScan: objOop + "Helper for markAndTrace:. + Mark the argument, and answer if its fields should be scanned now. + Immediate objects don't need to be marked. + Already marked objects have already been processed. + Pure bits objects don't need scanning, although their class does. + Weak objects should be pushed on the weakling stack. + Anything else need scanning." + | format | + <inline: true> + (manager isImmediate: objOop) ifTrue: + [^false]. + "if markAndTrace: is to follow and eliminate forwarding pointers + in its scan it cannot be handed an r-value which is forwarded." + self assert: (manager isForwarded: objOop) not. + (manager isMarked: objOop) ifTrue: + [^false]. + manager setIsMarkedOf: objOop to: true. + format := manager formatOf: objOop. + (manager isPureBitsFormat: format) ifTrue: "avoid pushing non-pointer objects on the markStack." + ["Avoid tracing classes of non-objects on the heap, e.g. IRC caches, Sista counters." + (manager classIndexOf: objOop) > manager lastClassIndexPun ifTrue: + [self markAndTraceClassOf: objOop]. + ^false]. + (manager isWeakFormat: format) ifTrue: "push weaklings on the weakling stack to scan later" + [manager push: objOop onObjStack: manager weaklingStack. + ^false]. + ((manager isEphemeronFormat: format) + and: [manager activeAndDeferredScan: objOop]) ifTrue: + [^false]. + ^true! Item was added: + ----- Method: SpurAllAtOnceMarker>>markAndTrace: (in category 'marking') ----- + markAndTrace: objOop + "Mark the argument, and all objects reachable from it, and any remaining objects + on the mark stack. Follow forwarding pointers in the scan." + <api> + <inline: #never> + "if markAndTrace: is to follow and eliminate forwarding pointers + in its scan it cannot be handed an r-value which is forwarded. + The assert for this is in markAndShouldScan:" + (self markAndShouldScan: objOop) ifFalse: + [^self]. + + "Now scan the object, and any remaining objects on the mark stack." + self markLoopFrom: objOop! Item was added: + ----- Method: SpurAllAtOnceMarker>>markAndTraceClassOf: (in category 'marking') ----- + markAndTraceClassOf: objOop + "Ensure the class of the argument is marked, pushing it on the markStack if not already marked. + And for one-way become, which can create duplicate entries in the class table, make sure + objOop's classIndex refers to the classObj's actual classIndex. + Note that this is recursive, but the metaclass chain should terminate quickly." + <inline: false> + | classIndex classObj realClassIndex | + classIndex := manager classIndexOf: objOop. + classObj := manager classOrNilAtIndex: classIndex. + self assert: (coInterpreter objCouldBeClassObj: classObj). + realClassIndex := manager rawHashBitsOf: classObj. + (classIndex ~= realClassIndex + and: [classIndex > manager lastClassIndexPun]) ifTrue: + [manager setClassIndexOf: objOop to: realClassIndex]. + (manager isMarked: classObj) ifFalse: + [manager setIsMarkedOf: classObj to: true. + self markAndTraceClassOf: classObj. + manager push: classObj onObjStack: manager markStack]! Item was added: + ----- Method: SpurAllAtOnceMarker>>markAndTraceExtraRoots (in category 'marking') ----- + markAndTraceExtraRoots + | oop | + self assert: manager remapBufferCount = 0. + + 1 to: manager extraRootCount do: + [:i| + oop := (manager extraRoots at: i) at: 0. + ((manager isImmediate: oop) or: [manager isFreeObject: oop]) ifFalse: + [self markAndTrace: oop]]! Item was added: + ----- Method: SpurAllAtOnceMarker>>markAndTraceHiddenRoots (in category 'marking') ----- + markAndTraceHiddenRoots + "The hidden roots hold both the class table pages and the obj stacks, + and hence need special treatment. The obj stacks must be marked + specially; their pages must be marked, but only the contents of the + mournQueue should be marked. + + If a class table page is weak we can mark and trace the hiddenRoots, + which will not trace through class table pages because they are weak. + But if class table pages are strong, we must mark the pages and *not* + trace them so that only classes reachable from the true roots will be + marked, and unreachable classes will be left unmarked." + + self markAndTraceObjStack: manager markStack andContents: false. + self markAndTraceObjStack: manager weaklingStack andContents: false. + self markAndTraceObjStack: manager mournQueue andContents: true. + + manager setIsMarkedOf: manager rememberedSetObj to: true. + manager setIsMarkedOf: manager freeListsObj to: true. + + (manager isWeakNonImm: manager classTableFirstPage) ifTrue: + [^self markAndTrace: manager hiddenRootsObj]. + + manager setIsMarkedOf: manager hiddenRootsObj to: true. + self markAndTrace: manager classTableFirstPage. + 1 to: manager numClassTablePages - 1 do: + [:i| manager setIsMarkedOf: (manager fetchPointer: i ofObject: manager hiddenRootsObj) + to: true]! Item was added: + ----- Method: SpurAllAtOnceMarker>>markAndTraceObjStack:andContents: (in category 'marking') ----- + markAndTraceObjStack: stackOrNil andContents: markAndTraceContents + "An obj stack is a stack of objects stored in a hidden root slot, such + as the markStack or the ephemeronQueue. It is a linked list of + segments, with the hot end at the head of the list. It is a word object. + The stack pointer is in ObjStackTopx and 0 means empty." + <inline: false> + | index field | + stackOrNil = manager nilObj ifTrue: + [^self]. + manager setIsMarkedOf: stackOrNil to: true. + self assert: (manager numSlotsOfAny: stackOrNil) = ObjStackPageSlots. + field := manager fetchPointer: ObjStackNextx ofObject: stackOrNil. + field ~= 0 ifTrue: + [self markAndTraceObjStack: field andContents: markAndTraceContents]. + field := stackOrNil. + [field := manager fetchPointer: ObjStackFreex ofObject: field. + field ~= 0] whileTrue: + [manager setIsMarkedOf: field to: true]. + markAndTraceContents ifFalse: + [^self]. + "There are four fixed slots in an obj stack, and a Topx of 0 indicates empty, so + if there were 6 slots in an oop stack, full would be 2, and the last 0-rel index is 5." + index := (manager fetchPointer: ObjStackTopx ofObject: stackOrNil) + ObjStackNextx. + [index >= ObjStackFixedSlots] whileTrue: + [field := manager followObjField: index ofObject: stackOrNil. + (manager isImmediate: field) ifFalse: + [self markAndTrace: field]. + index := index - 1]! Item was added: + ----- Method: SpurAllAtOnceMarker>>markAndTraceWeaklingsFrom: (in category 'weakness and ephemerality') ----- + markAndTraceWeaklingsFrom: startIndex + "Mark weaklings on the weaklingStack, ignoring startIndex + number of elements on the bottom of the stack. Answer + the size of the stack *before* the enumeration began." + ^manager objStack: manager weaklingStack from: startIndex do: + [:weakling| + self deny: (manager isForwarded: weakling). + self markAndTraceClassOf: weakling. + "N.B. generateToByDoLimitExpression:negative:on: guards against (unsigned)0 - 1 going +ve" + 0 to: (manager numStrongSlotsOfWeakling: weakling) - 1 do: + [:i| | field | + field := manager followOopField: i ofObject: weakling. + ((manager isImmediate: field) or: [manager isMarked: field]) ifFalse: + [self markAndTrace: field]]]! Item was added: + ----- Method: SpurAllAtOnceMarker>>markInactiveEphemerons (in category 'weakness and ephemerality') ----- + markInactiveEphemerons + "Go through the unscanned ephemerons, marking the inactive ones, and + removing them from the unscanned ephemerons. Answer if any inactive + ones were found. We cannot fire the ephemerons until all are found to + be active since scan-marking an inactive ephemeron later in the set may + render a previously-observed active ephemeron as inactive." + | foundInactive ptr | + foundInactive := false. + ptr := manager unscannedEphemerons start. + [ptr < manager unscannedEphemerons top] whileTrue: + [| ephemeron key | + key := manager followedKeyOfEphemeron: (ephemeron := manager longAt: ptr). + ((manager isImmediate: key) or: [manager isMarked: key]) + ifTrue: + [foundInactive := true. + "Now remove the inactive ephemeron from the set, and scan-mark it. + Scan-marking it may add more ephemerons to the set." + manager unscannedEphemerons top: manager unscannedEphemerons top - manager bytesPerOop. + manager unscannedEphemerons top > ptr ifTrue: + [manager longAt: ptr put: (manager longAt: manager unscannedEphemerons top)]. + self markAndTrace: ephemeron] + ifFalse: + [ptr := ptr + manager bytesPerOop]]. + ^foundInactive! Item was added: + ----- Method: SpurAllAtOnceMarker>>markLoopFrom: (in category 'marking') ----- + markLoopFrom: objOop + "Scan objOop and all objects on the mark stack, until the mark stack is empty. + N.B. When the incremental GC is written this will probably be refactored as + markLoopFrom: objOop while: aBlock" + <inline: true> + | objToScan field index numStrongSlots scanLargeObject | + + "Now scan the object, and any remaining objects on the mark stack." + objToScan := objOop. + "To avoid overflowing the mark stack when we encounter large objects, we + push the obj, then its numStrongSlots, and then index the object from the stack." + [(manager isImmediate: objToScan) + ifTrue: [scanLargeObject := true] + ifFalse: + [numStrongSlots := manager numStrongSlotsOfInephemeral: objToScan. + scanLargeObject := numStrongSlots > self traceImmediatelySlotLimit]. + scanLargeObject + ifTrue: "scanning a large object. scan until hitting an unmarked object, then switch to it, if any." + [(manager isImmediate: objToScan) + ifTrue: + [index := manager integerValueOf: objToScan. + objToScan := manager topOfObjStack: manager markStack] + ifFalse: + [index := numStrongSlots. + self markAndTraceClassOf: objToScan]. + [index > 0] whileTrue: + [index := index - 1. + field := manager fetchPointer: index ofObject: objToScan. + (manager isNonImmediate: field) ifTrue: + [(manager isForwarded: field) ifTrue: "fixFollowedField: is /not/ inlined" + [field := manager fixFollowedField: index ofObject: objToScan withInitialValue: field]. + (self markAndShouldScan: field) ifTrue: + [index > 0 ifTrue: + [(manager topOfObjStack: manager markStack) ~= objToScan ifTrue: + [manager push: objToScan onObjStack: manager markStack]. + manager push: (manager integerObjectOf: index) onObjStack: manager markStack]. + objToScan := field. + index := -1]]]. + index >= 0 ifTrue: "if loop terminated without finding an unmarked referent, switch to top of stack." + [objToScan := manager popObjStack: manager markStack. + objToScan = objOop ifTrue: + [objToScan := manager popObjStack: manager markStack]]] + ifFalse: "scanning a small object. scan, marking, pushing unmarked referents, then switch to the top of the stack." + [index := numStrongSlots. + self markAndTraceClassOf: objToScan. + [index > 0] whileTrue: + [index := index - 1. + field := manager fetchPointer: index ofObject: objToScan. + (manager isNonImmediate: field) ifTrue: + [(manager isForwarded: field) ifTrue: "fixFollowedField: is /not/ inlined" + [field := manager fixFollowedField: index ofObject: objToScan withInitialValue: field]. + (self markAndShouldScan: field) ifTrue: + [manager push: field onObjStack: manager markStack. + ((manager rawNumSlotsOf: field) > self traceImmediatelySlotLimit + and: [(numStrongSlots := manager numStrongSlotsOfInephemeral: field) > self traceImmediatelySlotLimit]) ifTrue: + [manager push: (manager integerObjectOf: numStrongSlots) onObjStack: manager markStack]]]]. + objToScan := manager popObjStack: manager markStack]. + objToScan notNil] whileTrue! Item was added: + ----- Method: SpurAllAtOnceMarker>>markWeaklingsAndMarkAndFireEphemerons (in category 'weakness and ephemerality') ----- + markWeaklingsAndMarkAndFireEphemerons + "After the initial scan-mark is complete ephemerons can be processed. + Weaklings have accumulated on the weaklingStack, but more may be + uncovered during ephemeron processing. So trace the strong slots + of the weaklings, and as ephemerons are processed ensure any newly + reached weaklings are also traced." + | numTracedWeaklings | + <inline: false> + numTracedWeaklings := 0. + [coInterpreter markAndTraceUntracedReachableStackPages. + coInterpreter markAndTraceMachineCodeOfMarkedMethods. + "Make sure all reached weaklings have their strong slots traced before firing ephemerons..." + [numTracedWeaklings := self markAndTraceWeaklingsFrom: numTracedWeaklings. + (manager sizeOfObjStack: manager weaklingStack) > numTracedWeaklings] whileTrue. + manager noUnscannedEphemerons ifTrue: + [coInterpreter + markAndTraceUntracedReachableStackPages; + markAndTraceMachineCodeOfMarkedMethods; + freeUntracedStackPages; + freeUnmarkedMachineCode. + ^self]. + self markInactiveEphemerons ifFalse: + [manager fireAllUnscannedEphemerons]. + self markAllUnscannedEphemerons] + repeat! Item was added: + ----- Method: SpurAllAtOnceMarker>>markersMarkObjects: (in category 'marking') ----- + markersMarkObjects: objectsShouldBeUnmarkedAndUnmarkedClassesShouldBeExpunged + <inline: #never> "for profiling" + "Mark all accessible objects. objectsShouldBeUnmarkedAndUnmarkedClassesShouldBeExpunged + is true if all objects are unmarked and/or if unmarked classes shoud be removed from the class table." + "If the incremental collector is running mark bits may be set; stop it and clear them if necessary." + self cCode: '' inSmalltalk: [coInterpreter transcript nextPutAll: 'marking...'; flush]. + manager runLeakCheckerFor: GCModeFull. + + manager shutDownGlobalIncrementalGC: objectsShouldBeUnmarkedAndUnmarkedClassesShouldBeExpunged. + manager initializeUnscannedEphemerons. + manager initializeMarkStack. + manager initializeWeaklingStack. + marking := true. + self markAccessibleObjectsAndFireEphemerons. + manager expungeDuplicateAndUnmarkedClasses: objectsShouldBeUnmarkedAndUnmarkedClassesShouldBeExpunged. + manager nilUnmarkedWeaklingSlotsExcludingYoungObjects: false. + marking := false! Item was added: + ----- Method: SpurAllAtOnceMarker>>traceImmediatelySlotLimit (in category 'marking') ----- + traceImmediatelySlotLimit + "Arbitrary level at which to defer tracing large objects until later. + The average slot size of Smalltalk objects is typically near 8. + We do require traceImmediatelySlotLimit to be < numSlotsMask." + ^64! Item was added: + SpurAllAtOnceMarker subclass: #SpurAllAtOnceMarkerSimulator + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'VMMaker-SpurMemoryManagerSimulation'! Item was changed: CogClass subclass: #SpurCompactor instanceVariableNames: 'coInterpreter manager scavenger' classVariableNames: '' poolDictionaries: 'SpurMemoryManagementConstants VMBasicConstants VMSpurObjectRepresentationConstants' + category: 'VMMaker-SpurGarbageCollector'! - category: 'VMMaker-SpurMemoryManager'! + !SpurCompactor commentStamp: '' prior: 0! - !SpurCompactor commentStamp: 'cb 4/27/2018 09:38' prior: 0! Abstract common superclass of all compactors to define apis and simulation variables. The full GC in Spur is split in two, the marking phase and the compactor phase. The subclasses of SpurCompactor are implementations of the second phase, so they are called once the marking phase is finished. SpurCompactor is reponsible for: - freeing unmarked objects - compacting the live old space objects (though each subclass define what it does, some spurCompactor may not compact) - unmarking all objects remaining live - updating oops directly referred by the VM when they are moved (remapObj:/shouldRemapObj: thingy) The main apis are the following: - biasForGC/biasForSnapshot: tells the compactor if the GC is performed for snapshots or not, in general we want to compact more aggressively for snapshots to avoid saving large files with many unused space. - compact: main API, should free the unmarked object, unmark the objects remaining live and potentially compact the heap - remapObj:/shouldRemapObj: => Not really sure what this does, it seems it has to do with updating oops directly referred by the VM when they are moved. - postSwizzleAction: if you want to do something at start-up after swizzle phase (typically useful if your compaction algo uses segInfos) Instance Variables coInterpreter: <StackInterpreter> scavenger: <SpurGenerationScavenger> manager: <SpurMemoryManager>! Item was added: + CogClass subclass: #SpurGarbageCollector + instanceVariableNames: 'marker scavenger compactor manager coInterpreter allocatorShouldAllocateBlack' + classVariableNames: '' + poolDictionaries: 'SpurMemoryManagementConstants' + category: 'VMMaker-SpurGarbageCollector'! Item was added: + ----- Method: SpurGarbageCollector class>>classesForTranslation (in category 'as yet unclassified') ----- + classesForTranslation + + ^ ((self withAllSuperclasses copyUpThrough: SpurGarbageCollector) reverse) , {SpurCompactor . SpurGenerationScavenger}! Item was added: + ----- Method: SpurGarbageCollector class>>compactorClass (in category 'as yet unclassified') ----- + compactorClass + + self shouldBeImplemented! Item was added: + ----- Method: SpurGarbageCollector class>>declareCVarsIn: (in category 'as yet unclassified') ----- + declareCVarsIn: aCCodeGenerator + + super declareCVarsIn: aCCodeGenerator. + aCCodeGenerator + var: #allocatorShouldAllocateBlack type: #usqInt.! Item was added: + ----- Method: SpurGarbageCollector class>>markerClass (in category 'as yet unclassified') ----- + markerClass + + self shouldBeImplemented! Item was added: + ----- Method: SpurGarbageCollector>>allocatorShouldAllocateBlack (in category 'accessing') ----- + allocatorShouldAllocateBlack + + <cmacro: '() GIV(allocatorShouldAllocateBlack)'> + ^ allocatorShouldAllocateBlack! Item was added: + ----- Method: SpurGarbageCollector>>allocatorShouldAllocateBlack: (in category 'accessing') ----- + allocatorShouldAllocateBlack: anObject + + allocatorShouldAllocateBlack := anObject.! Item was added: + ----- Method: SpurGarbageCollector>>assertSettingGCFlagsIsOk: (in category 'as yet unclassified') ----- + assertSettingGCFlagsIsOk: objOop + + <doNotGenerate>! Item was added: + ----- Method: SpurGarbageCollector>>coInterpreter (in category 'accessing') ----- + coInterpreter + + ^ coInterpreter! Item was added: + ----- Method: SpurGarbageCollector>>coInterpreter: (in category 'accessing') ----- + coInterpreter: anObject + + <doNotGenerate> + coInterpreter := anObject.! Item was added: + ----- Method: SpurGarbageCollector>>compactor (in category 'accessing') ----- + compactor + + <doNotGenerate> + ^ compactor! Item was added: + ----- Method: SpurGarbageCollector>>compactor: (in category 'accessing') ----- + compactor: anObject + + compactor := anObject.! Item was added: + ----- Method: SpurGarbageCollector>>doScavenge: (in category 'scavenge') ----- + doScavenge: tenuringCriterion + "The inner shell for scavenge, abstrascted out so globalGarbageCollect can use it." + <inline: false> + manager doAllocationAccountingForScavenge. + manager gcPhaseInProgress: ScavengeInProgress. + manager pastSpaceStart: (scavenger scavenge: tenuringCriterion). + self assert: (self + oop: manager pastSpaceStart + isGreaterThanOrEqualTo: scavenger pastSpace start + andLessThanOrEqualTo: scavenger pastSpace limit). + manager freeStart: scavenger eden start. + manager gcPhaseInProgress: 0. + manager resetAllocationAccountingAfterGC. + + self incrementalCollect! Item was added: + ----- Method: SpurGarbageCollector>>doScavengeWithoutIncrementalCollect: (in category 'scavenge') ----- + doScavengeWithoutIncrementalCollect: tenuringCriterion + "The inner shell for scavenge, abstrascted out so globalGarbageCollect can use it." + <inline: false> + manager doAllocationAccountingForScavenge. + manager gcPhaseInProgress: ScavengeInProgress. + manager pastSpaceStart: (scavenger scavenge: tenuringCriterion). + self assert: (self + oop: manager pastSpaceStart + isGreaterThanOrEqualTo: scavenger pastSpace start + andLessThanOrEqualTo: scavenger pastSpace limit). + manager freeStart: scavenger eden start. + manager gcPhaseInProgress: 0. + manager resetAllocationAccountingAfterGC.! Item was added: + ----- Method: SpurGarbageCollector>>finishGCPass (in category 'as yet unclassified') ----- + finishGCPass + "finish the startet GC pass" + + ^ self subclassResponsibility! Item was added: + ----- Method: SpurGarbageCollector>>fullGC (in category 'global') ----- + fullGC + + ^ self subclassResponsibility! Item was added: + ----- Method: SpurGarbageCollector>>gcForSnapshot (in category 'as yet unclassified') ----- + gcForSnapshot + + ^ self shouldBeImplemented! Item was added: + ----- Method: SpurGarbageCollector>>incrementalCollect (in category 'global') ----- + incrementalCollect + + ^ self subclassResponsibility! Item was added: + ----- Method: SpurGarbageCollector>>initialize (in category 'initialize-release') ----- + initialize + + allocatorShouldAllocateBlack := false! Item was added: + ----- Method: SpurGarbageCollector>>isIncremental (in category 'testing') ----- + isIncremental + + ^ false! Item was added: + ----- Method: SpurGarbageCollector>>isOkToDeleteSegment: (in category 'testing') ----- + isOkToDeleteSegment: segment + + ^ self subclassResponsibility! Item was added: + ----- Method: SpurGarbageCollector>>isOkToScavengeRememberedObject: (in category 'testing') ----- + isOkToScavengeRememberedObject: objOop + + ^ true! Item was added: + ----- Method: SpurGarbageCollector>>isStopTheWorld (in category 'testing') ----- + isStopTheWorld + + ^ false! Item was added: + ----- Method: SpurGarbageCollector>>manager (in category 'accessing') ----- + manager + + ^ manager! Item was added: + ----- Method: SpurGarbageCollector>>manager: (in category 'accessing') ----- + manager: anObject + + <doNotGenerate> + manager := anObject.! Item was added: + ----- Method: SpurGarbageCollector>>markObjects: (in category 'as yet unclassified') ----- + markObjects: objectsShouldBeUnmarkedAndUnmarkedClassesShouldBeExpunged + + marker markersMarkObjects: objectsShouldBeUnmarkedAndUnmarkedClassesShouldBeExpunged! Item was added: + ----- Method: SpurGarbageCollector>>markObjectsCompletely (in category 'as yet unclassified') ----- + markObjectsCompletely + "all reachable objects ind young and old space are marked after this call" + + self subclassResponsibility! Item was added: + ----- Method: SpurGarbageCollector>>markObjectsForEnumerationPrimitives (in category 'as yet unclassified') ----- + markObjectsForEnumerationPrimitives + + ^ self shouldBeImplemented! Item was added: + ----- Method: SpurGarbageCollector>>marker (in category 'accessing') ----- + marker + + <doNotGenerate> + ^ marker! Item was added: + ----- Method: SpurGarbageCollector>>marker: (in category 'accessing') ----- + marker: anObject + + <doNotGenerate> + marker := anObject.! Item was added: + ----- Method: SpurGarbageCollector>>maybeModifyCopiedObject: (in category 'object creation barriers') ----- + maybeModifyCopiedObject: objOop + + <doNotGenerate>! Item was added: + ----- Method: SpurGarbageCollector>>maybeModifyForwarder: (in category 'object creation barriers') ----- + maybeModifyForwarder: objOop + + <doNotGenerate>! Item was added: + ----- Method: SpurGarbageCollector>>maybeModifyGCFlagsOf: (in category 'object creation barriers') ----- + maybeModifyGCFlagsOf: objOop + + <doNotGenerate>! Item was added: + ----- Method: SpurGarbageCollector>>scavenger (in category 'accessing') ----- + scavenger + + ^ scavenger! Item was added: + ----- Method: SpurGarbageCollector>>scavenger: (in category 'accessing') ----- + scavenger: anObject + + scavenger := anObject.! Item was added: + ----- Method: SpurGarbageCollector>>scavengingGCTenuringIf: (in category 'scavenge') ----- + scavengingGCTenuringIf: tenuringCriterion + "Run the scavenger." + <inline: false> + self assert: manager remapBufferCount = 0. + (self asserta: scavenger eden limit - manager freeStart > coInterpreter interpreterAllocationReserveBytes) ifFalse: + [coInterpreter tab; + printNum: scavenger eden limit - manager freeStart; space; + printNum: coInterpreter interpreterAllocationReserveBytes; space; + printNum: coInterpreter interpreterAllocationReserveBytes - (scavenger eden limit - manager freeStart); cr]. + manager checkMemoryMap. + manager checkFreeSpace: GCModeNewSpace. + manager runLeakCheckerFor: GCModeNewSpace. + + coInterpreter + preGCAction: GCModeNewSpace; + "would prefer this to be in mapInterpreterOops, but + compatibility with ObjectMemory dictates it goes here." + flushMethodCacheFrom: manager newSpaceStart to: manager oldSpaceStart. + manager needGCFlag: false. + + manager gcStartUsecs: coInterpreter ioUTCMicrosecondsNow. + + self doScavenge: tenuringCriterion. + + manager statScavenges: manager statScavenges + 1. + manager statGCEndUsecs: coInterpreter ioUTCMicrosecondsNow. + manager statSGCDeltaUsecs: manager statGCEndUsecs - manager gcStartUsecs. + manager statScavengeGCUsecs: manager statScavengeGCUsecs + manager statSGCDeltaUsecs. + manager statRootTableCount: scavenger rememberedSetSize. + + scavenger logScavenge. + + coInterpreter postGCAction: GCModeNewSpace. + + manager runLeakCheckerFor: GCModeNewSpace. + manager checkFreeSpace: GCModeNewSpace! Item was added: + ----- Method: SpurGarbageCollector>>sufficientSpaceAfterGC: (in category 'as yet unclassified') ----- + sufficientSpaceAfterGC: numBytes + + self subclassResponsibility! Item was changed: CogClass subclass: #SpurGenerationScavenger instanceVariableNames: 'coInterpreter manager eden futureSpace pastSpace futureSurvivorStart rememberedSet rememberedSetSize previousRememberedSetSize rememberedSetRedZone rememberedSetLimit refCountToShrinkRT weakList ephemeronList tenureCriterion tenureThreshold tenuringClassIndex tenuringProportion numRememberedEphemerons scavengeLog scavengeLogRecord statSurvivorCount statTenures' classVariableNames: '' poolDictionaries: 'SpurMemoryManagementConstants' + category: 'VMMaker-SpurGarbageCollector'! - category: 'VMMaker-SpurMemoryManager'! + !SpurGenerationScavenger commentStamp: '' prior: 0! - !SpurGenerationScavenger commentStamp: 'eem 11/7/2017 17:26' prior: 0! SpurGenerationScavenger is an implementation of David Ungar's Generation Scavenging garbage collection algorithm. See Generation Scavenging, A Non-disruptive, High-Performance Storage Reclamation Algorithm David Ungar Proceeding SDE 1 Proceedings of the first ACM SIGSOFT/SIGPLAN software engineering symposium on Practical software development environments Pages 157 - 167 ACM New York, NY, USA ©1984 Also relevant are An adaptive tenuring policy for generation scavengers David Ungar & Frank Jackson ACM Transactions on Programming Languages and Systems (TOPLAS) TOPLAS Homepage archive Volume 14 Issue 1, Jan. 1992 Pages 1 - 27 ACM New York, NY, USA ©1992 and Ephemerons: a new finalization mechanism Barry Hayes Proceedings of the 12th ACM SIGPLAN conference on Object-oriented programming, systems, languages, and applications Pages 176-183 ACM New York, NY, USA ©1997 See text below the variable definitions and explanation below for a full explanation of weak and ephemeron processing. Instance Variables coInterpreter: <StackInterpreterSimulator|CogVMSimulator> eden: <SpurNewSpaceSpace> ephemeronList: <Integer|nil> futureSpace: <SpurNewSpaceSpace> futureSurvivorStart: <Integer address> manager: <SpurMemoryManager|Spur32BitMMLESimulator et al> numRememberedEphemerons: <Integer> pastSpace: <SpurNewSpaceSpace> previousRememberedSetSize: <Integer> rememberedSet: <CArrayAccessor on: Array> rememberedSetSize: <Integer> tenuringProportion: <Float> tenuringThreshold: <Integer address> weakList: <Integer|nil> coInterpreter - the interpreter/vm, in this context, the mutator manager - the Spur memory manager eden - the space containing newly created objects futureSpace - the space to which surviving objects are copied during a scavenge futureSurvivorStart - the allocation pointer into futureSpace pastSpace - the space surviving objects live in until the next scavenge rememberedSet - the root old space objects that refer to objects in new space; a scavenge starts form these roots and the interpreter's stack rememberedSetSize - the size of the remembered set, also the first unused index in the rememberedSet previousRememberedSetSize: - the size of the remembered set before scavenging objects in future space. numRememberedEphemerons - the number of unscavenged ephemerons at the front of the rememberedSet. ephemeronList - the head of the list of corpses of unscavenged ephemerons reached in the current phase weakList - the head of the list of corpses of weak arrays reached during the scavenge. tenuringProportion - the amount of pastSpace below which the system will not tenure unless futureSpace fills up, and above which it will eagerly tenure tenuringThreshold - the pointer into pastSpace below which objects will be tenured Weakness and Ephemerality in the Scavenger. Weak arrays should not hold onto their referents (except from their strong fileds, their named inst vars). Ephemerons are objects that implement instance-based finalization; attaching an ephemeron to an object keeps that object alive and causes the ephemeron to "fire" when the object is only reachable from the ephemeron (or other ephemerons & weak arrays). They are a special kind of Associations that detect when their keys are about to die, i.e. when an ephemeron's key is not reachable from the roots except from weak arrays and other ephemerons with about-to-die keys. Note that if an ephemeron's key is not about to die then references from the rest of the ephemeron can indeed prevent ephemeron keys from dying. The scavenger is concerned with collecting objects in new space, therefore it ony deals with weak arrays and ephemerons that are either in the remembered set or in new space. By deferring scanning these objects until other reachable objects have been scavenged, the scavenger can detect dead or dying references. Weak Array Processing In the case of weak arrays this is simple. The scavenger refuses to scavenge the referents of weak arrays in scavengeReferentsOf: until the entire scavenge is over. It then scans the weak arrays in the remembered set and in future space and nils all fields in them that are referring to unforwarded objects in eden and past space, because these objects have not survived the scavenge. The root weak arrays remaining to be scavenged are in the remembered table. Surviving weak arrays in future space are collected on a list. The list is threaded through the corpses of weak arrays in eden and/or past space. weakList holds the slot offset of the first weak array found in eden and/or past space. The next offset is stored in the weak array corpse's identityHash and format fields (22 bits & 5 bits of allocationUnits, for a max new space size of 2^28 bytes, 256Mb). The list is threaded throguh corpses, but the surviving arrays are pointed to by the corpses' forwarding pointers. Ephemeron Processing The case of ephemerons is a little more complicated because an ephemeron's key should survive. The scavenger is cyclical. It scavenges the remembered set, which may copy and forward surviving objects in past and/or eden spaces to future space. It then scavenges those promoted objects in future space until no more are promoted, which may in turn remember more objects. The cycles continue until no more objects get promoted to future space and no more objects get remembered. At this point all surviving objecta are in futureSpace. So if the scavenger does not scan ephemerons in the remembered set or in future space until the scavenger finishes cycling, it can detect ephemerons whose keys are about to die because these will be unforwarded objects in eden and/or past space. Ephemerons encountered in the remembered set are either processed like ordinary objects if their keys have been promoted to futureSpace, or are moved to the front of the rememberedSet (because, dear reader, it is a sequence) if their keys have not been promoted. Ephemerons encountered in scavengeReferentsOf: are either scanned like normal objects if their keys have been promoted, or added to the ephemeronList, organized identically to the weakList, if their keys are yet to be promoted. Since references from other ephemerons with surviving keys to ephemeron keys can and should prevent the ephemerons whose keys they are from firing the scavenger does not fire ephemerons unless all unscavenged ephemerons have unscavenged keys. So the unsca venged ephemerons (they will be at the beginning of the remembered set and on the ephemeronList) are scanned and any that have promoted keys are scavenged. But if no unscavenged ephemerons have surviving keys then all the unscavenged ephemerons are fired and then scavenged. This in turn may remember more objects and promote more objects to future space, and encounter more unscavenged ephemerons. So the scavenger continues until no more objects are remembered, no more objects are promoted to future space and no more unscavenged ephemerons exist.! Item was removed: - ----- Method: SpurGenerationScavenger class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') ----- - isNonArgumentImplicitReceiverVariableName: instVarName - ^#('self' 'coInterpreter' 'manager') includes: instVarName! Item was changed: ----- Method: SpurGenerationScavenger>>copyToOldSpace:bytes:format: (in category 'scavenger') ----- copyToOldSpace: survivor bytes: bytesInObject format: formatOfSurvivor "Copy survivor to oldSpace. Answer the new oop of the object." <inline: #never> "Should be too infrequent to lower icache density of copyAndForward:" | nTenures startOfSurvivor newStart newOop | + self assert: formatOfSurvivor = (manager formatOf: survivor). + self assert: ((manager isMarked: survivor) not or: [tenureCriterion = MarkOnTenure]). + ((manager isMarked: survivor) not or: [tenureCriterion = MarkOnTenure]) + ifFalse: [coInterpreter longPrintOop: survivor]. + self assert: ([tenureCriterion = TenureToShrinkRT - self assert: (formatOfSurvivor = (manager formatOf: survivor) - and: [((manager isMarked: survivor) not or: [tenureCriterion = MarkOnTenure]) - and: [tenureCriterion = TenureToShrinkRT or: [(manager isPinned: survivor) not + and: [(manager isRemembered: survivor) not]]]). - and: [(manager isRemembered: survivor) not]]]]). nTenures := statTenures. startOfSurvivor := manager startOfObject: survivor. newStart := manager allocateOldSpaceChunkOfBytes: bytesInObject. newStart ifNil: [manager growOldSpaceByAtLeast: 0. "grow by growHeadroom" newStart := manager allocateOldSpaceChunkOfBytes: bytesInObject. newStart ifNil: [self error: 'out of memory']]. "manager checkFreeSpace." manager memcpy: newStart asVoidPointer _: startOfSurvivor asVoidPointer _: bytesInObject. newOop := newStart + (survivor - startOfSurvivor). + tenureCriterion = TenureToShrinkRT ifTrue: - tenureCriterion >= (TenureToShrinkRT min: MarkOnTenure) ifTrue: - [tenureCriterion = TenureToShrinkRT ifTrue: [manager rtRefCountOf: newOop put: 0]. + + manager gc maybeModifyCopiedObject: newOop. + - tenureCriterion = MarkOnTenure ifTrue: - [manager setIsMarkedOf: newOop to: true]]. statTenures := nTenures + 1. (manager isAnyPointerFormat: formatOfSurvivor) ifTrue: ["A very quick and dirty scan to find young referents. If we misidentify bytes in a CompiledMethod as young we don't care; it's unlikely, and a subsequent scan of the rt will filter the object out. But it's good to filter here because otherwise an attempt to shrink the RT may simply fill it up with new objects, and here the data is likely in the cache." manager baseHeaderSize to: bytesInObject - (survivor - startOfSurvivor) - manager wordSize by: manager wordSize do: [:p| | field | field := manager longAt: survivor + p. (manager isReallyYoung: field) ifTrue: [self remember: newOop. ^newOop]]]. ^newOop! Item was changed: ----- Method: SpurGenerationScavenger>>processWeakSurvivor: (in category 'weakness and ephemerality') ----- processWeakSurvivor: weakObj "Process a weak survivor on the weakList. Those of its fields which have not survived the scavenge should be nilled, and if any are, the coInterpreter should be informed via fireFinalization:. Answer if the weakObj has any young referents." | weakObjShouldMourn hasYoungReferents numStrongSlots | weakObjShouldMourn := hasYoungReferents := false. "N.B. generateToByDoLimitExpression:negative:on: guards against (unsigned)0 - 1 going +ve" numStrongSlots := manager numFixedSlotsOf: weakObj. 0 to: numStrongSlots - 1 do: [:i| | referent | referent := manager fetchPointer: i ofObject: weakObj. ((manager isNonImmediate: referent) and: [manager isYoungObject: referent]) ifTrue: [hasYoungReferents := true]]. numStrongSlots to: (manager numSlotsOf: weakObj) - 1 do: [:i| | referent | referent := manager fetchPointer: i ofObject: weakObj. "Referent could be forwarded due to scavenging or a become:, don't assume." (manager isNonImmediate: referent) ifTrue: [(manager isForwarded: referent) ifTrue: [referent := manager followForwarded: referent. "weakObj is either young or already in remembered table; no need to check" self assert: ((manager isReallyYoungObject: weakObj) or: [manager isRemembered: weakObj]). manager storePointerUnchecked: i ofObject: weakObj withValue: referent]. (self isMaybeOldScavengeSurvivor: referent) ifTrue: [(manager isYoungObject: referent) ifTrue: [hasYoungReferents := true]] ifFalse: + [(self isOkToClearReference: referent) + ifTrue: [ + weakObjShouldMourn := true. + manager + storePointerUnchecked: i + ofObject: weakObj + withValue: manager nilObject]]]]. - [weakObjShouldMourn := true. - manager - storePointerUnchecked: i - ofObject: weakObj - withValue: manager nilObject]]]. weakObjShouldMourn ifTrue: [coInterpreter fireFinalization: weakObj]. ^hasYoungReferents! Item was changed: ----- Method: SpurGenerationScavenger>>scavengeReferentsOf: (in category 'scavenger') ----- scavengeReferentsOf: referrer "scavengeReferentsOf: referrer inspects all the pointers in referrer. If any are new objects, it has them moved to FutureSurvivorSpace, and answers truth. If there are no new referents, it answers falsity. To handle weak arrays, if the referrer is weak only scavenge strong slots and answer true so that it won't be removed from the remembered set until later." | fmt foundNewReferentOrIsWeakling numSlots | "forwarding objects should be followed by callers, unless the forwarder is a root in the remembered table." self assert: ((manager isForwarded: referrer) not or: [manager isRemembered: referrer]). "unscanned ephemerons should be scanned later." self assert: ((manager isEphemeron: referrer) not + or: [(manager gc isOkToClearReference: (manager keyOfEphemeron: referrer)) or: [(self isScavengeSurvivor: (manager keyOfEphemeron: referrer)) + or: [self is: referrer onWeaklingList: ephemeronList]]]). - or: [self is: referrer onWeaklingList: ephemeronList]]). fmt := manager formatOf: referrer. foundNewReferentOrIsWeakling := manager isWeakFormat: fmt. numSlots := manager numStrongSlotsOf: referrer format: fmt ephemeronInactiveIf: #isScavengeSurvivor:. 0 to: numSlots - 1 do: [:i| | referent newLocation | referent := manager fetchPointer: i ofMaybeForwardedObject: referrer. (manager isNonImmediate: referent) ifTrue: ["a forwarding pointer could be because of become: or scavenging." (manager isForwarded: referent) ifTrue: [referent := manager followForwarded: referent]. (manager isReallyYoungObject: referent) ifTrue: "if target is already in future space forwarding pointer was due to a become:." [(manager isInFutureSpace: referent) ifTrue: [newLocation := referent. foundNewReferentOrIsWeakling := true] ifFalse: [newLocation := self copyAndForward: referent. (manager isYoung: newLocation) ifTrue: [foundNewReferentOrIsWeakling := true]]. manager storePointerUnchecked: i ofMaybeForwardedObject: referrer withValue: newLocation] ifFalse: [manager storePointerUnchecked: i ofMaybeForwardedObject: referrer withValue: referent]]]. ^foundNewReferentOrIsWeakling! Item was changed: ----- Method: SpurGenerationScavenger>>scavengeRememberedSetStartingAt: (in category 'scavenger') ----- scavengeRememberedSetStartingAt: n "scavengeRememberedSetStartingAt: n traverses objects in the remembered set starting at the nth one. If the object does not refer to any new objects, it is removed from the set. Otherwise, its new referents are scavenged. Defer scavenging ephemerons until after a complete scavenge has been performed, so that triggered ephemerons can be fired. Move them to the front of the set and count them in numRememberedEphemerons for later scanning." <inline: false> | destIndex sourceIndex referrer | sourceIndex := destIndex := n. [sourceIndex < rememberedSetSize] whileTrue: ["*Don't* follow forwarding pointers here. oldSpace objects may refer to these roots, and so they can't be removed in the scavenge." referrer := rememberedSet at: sourceIndex. "Any potential firing ephemerons should not be scanned yet. Move any to the front of the set to save time in later scanning." ((manager isEphemeron: referrer) and: [(self isScavengeSurvivor: ((manager keyOfEphemeron: referrer))) not]) ifTrue: [self assert: destIndex >= numRememberedEphemerons. rememberedSet at: destIndex put: (rememberedSet at: numRememberedEphemerons); at: numRememberedEphemerons put: referrer. numRememberedEphemerons := numRememberedEphemerons + 1. destIndex := destIndex + 1] ifFalse: + [((manager gc isOkToScavengeRememberedObject: referrer) and: [self scavengeReferentsOf: referrer]) - [(self scavengeReferentsOf: referrer) ifTrue: [rememberedSet at: destIndex put: referrer. destIndex := destIndex + 1] ifFalse: [manager setIsRememberedOf: referrer to: false]]. sourceIndex := sourceIndex + 1]. rememberedSetSize := destIndex. self assert: self noUnfiredEphemeronsAtEndOfRememberedSet! Item was changed: ----- Method: SpurGenerationScavenger>>scavengeUnfiredEphemeronsInRememberedSet (in category 'weakness and ephemerality') ----- scavengeUnfiredEphemeronsInRememberedSet "There are ephemerons to be scavenged in the remembered set. Scavenge any with unfired (live) keys, removing them from the unscavenged ephemerons, and from the set if they no longer refer to new objects, and answer if any with unfired keys were found." | unfiredEphemeronsScavenged i referrer hasNewReferents | unfiredEphemeronsScavenged := false. i := 0. [i < numRememberedEphemerons] whileTrue: [referrer := rememberedSet at: i. self assert: (manager isEphemeron: referrer). + ((manager gc isOkToClearReference: (manager keyOfEphemeron: referrer)) and: [self isScavengeSurvivor: (manager keyOfEphemeron: referrer)]) - (self isScavengeSurvivor: (manager keyOfEphemeron: referrer)) ifTrue: [unfiredEphemeronsScavenged := true. hasNewReferents := self scavengeReferentsOf: referrer. "remove from unscanned ephemerons in set by swapping with last ephemeron" numRememberedEphemerons := numRememberedEphemerons - 1. rememberedSet at: i put: (rememberedSet at: numRememberedEphemerons). hasNewReferents ifTrue: "keep in set" [rememberedSet at: numRememberedEphemerons put: referrer] ifFalse: "remove from set by overwriting with next-to-be scanned" [previousRememberedSetSize := previousRememberedSetSize - 1. rememberedSetSize := rememberedSetSize - 1. rememberedSet at: numRememberedEphemerons put: (rememberedSet at: previousRememberedSetSize); at: previousRememberedSetSize put: (rememberedSet at: rememberedSetSize). manager setIsRememberedOf: referrer to: false]] ifFalse: [i := i + 1]]. ^unfiredEphemeronsScavenged! Item was changed: ----- Method: SpurGenerationScavengerSimulator>>scavenge: (in category 'scavenger') ----- scavenge: tenuringCriterion manager bootstrapping ifFalse: + [coInterpreter transcript nextPutAll: 'scavenging('; print: manager statScavenges; nextPutAll: ')...'; cr; flush. - [coInterpreter transcript nextPutAll: 'scavenging('; print: manager statScavenges; nextPutAll: ')...'; flush. cameFrom ifNotNil: [cameFrom := Dictionary new]]. ^super scavenge: tenuringCriterion! Item was changed: SpurCompactor subclass: #SpurHybridCompactor instanceVariableNames: 'planningCompactor selectiveCompactor planNotSelect' classVariableNames: '' poolDictionaries: '' + category: 'VMMaker-SpurGarbageCollector'! - category: 'VMMaker-SpurMemoryManager'! + !SpurHybridCompactor commentStamp: '' prior: 0! - !SpurHybridCompactor commentStamp: 'eem 6/6/2018 19:25' prior: 0! A SpurHybridCompactor is a compactor that uses SpurSelectiveCompactor for normal GC compactions, but uses SpurPlanningCompactor for snapshot. Instance Variables planNotSelect: <Boolean> planningCompactor: <SpurPlanningCompactor> selectiveCompactor: <SpurSelectiveCompactor> planNotSelect - the boolean that selects between the two compactors; if true it chooses SpurPlanningCompactor planningCompactor - the SpurPlanningCompactor selectiveCompactor - the SpurSelectiveCompactor ! Item was added: + SpurCompactor subclass: #SpurIncrementalCompactor + instanceVariableNames: 'isCompacting segmentToFill shouldCompact currentHeapPointer currentSegment' + classVariableNames: 'MaxOccupationForCompaction' + poolDictionaries: '' + category: 'VMMaker-SpurGarbageCollector'! Item was added: + ----- Method: SpurIncrementalCompactor class>>declareCVarsIn: (in category 'as yet unclassified') ----- + declareCVarsIn: aCCodeGenerator + + aCCodeGenerator var: #segmentToFill type: #'SpurSegmentInfo *'.! Item was added: + ----- Method: SpurIncrementalCompactor class>>initialize (in category 'as yet unclassified') ----- + initialize + super initialize. + "If the segment is occupied by more than MaxOccupationForCompaction, + it's not worth compacting it, whatever the rest of the system looks like. + MaxOccupationForCompaction is included in [0;16rFFFF]." + MaxOccupationForCompaction := 16rD000. "81%"! Item was added: + ----- Method: SpurIncrementalCompactor>>assertNoSegmentBeingCompacted (in category 'testing') ----- + assertNoSegmentBeingCompacted + "Assertion only - no segment is being claimed at this point. All being compacted bits get cleared during sweeping when setting the occupation of the segments" + | segInfo | + <var: 'segInfo' type: #'SpurSegmentInfo *'> + 0 to: manager numSegments - 1 do: + [:i| + segInfo := self addressOf: (manager segmentManager segments at: i). + self deny: (self isSegmentBeingCompacted: segInfo). + (self isSegmentBeingCompacted: segInfo) + ifTrue: [self cCode: 'raise(SIGINT)']].! Item was added: + ----- Method: SpurIncrementalCompactor>>cannotBeCompacted: (in category 'as yet unclassified') ----- + cannotBeCompacted: segInfo + + ^ (self isSegmentBeingCompacted: segInfo) or: [segInfo containsPinned or: [manager segmentManager isEmptySegment: segInfo]]! Item was added: + ----- Method: SpurIncrementalCompactor>>compact (in category 'api') ----- + compact + + <inline: #never> + + self incrementalCompact! Item was added: + ----- Method: SpurIncrementalCompactor>>compactSegment:freeStart:segIndex: (in category 'incremental compaction') ----- + compactSegment: segInfo freeStart: initialFreeStart segIndex: segIndex + <var: 'segInfo' type: #'SpurSegmentInfo *'> + + | currentEntity fillStart bytesToCopy bridge | + fillStart := initialFreeStart. + bridge := manager segmentManager bridgeFor: segInfo. + currentEntity := manager objectStartingAt: segInfo segStart. + + self deny: segIndex = 0. "Cannot compact seg 0" + [self oop: currentEntity isLessThan: bridge] whileTrue: + [(manager isFreeObject: currentEntity) + ifTrue: + [manager detachFreeObject: currentEntity. + "To avoid confusing too much Spur (especially the leak/free checks), we mark the free chunk as a word object." + manager set: currentEntity classIndexTo: manager wordSizeClassIndexPun formatTo: manager wordIndexableFormat] + ifFalse: + ["During the mutator runs new forwarding references can be created. Ignore them as they get resolved with the other forwarders in this segment in the next marking pass" + (manager isForwarded: currentEntity) not + ifTrue: ["Copy the object in segmentToFill and replace it by a forwarder." + bytesToCopy := manager bytesInBody: currentEntity. + + self migrate: currentEntity sized: bytesToCopy to: fillStart. + + fillStart := fillStart + bytesToCopy. + self assert: (self oop: fillStart isLessThan: (segmentToFill segLimit - manager bridgeSize))]]. + + currentEntity := manager objectAfter: currentEntity limit: manager endOfMemory]. + + self assert: currentEntity = bridge. + currentSegment := currentSegment + 1. + ^ fillStart! Item was added: + ----- Method: SpurIncrementalCompactor>>completeCompact (in category 'as yet unclassified') ----- + completeCompact + + | segInfo | + self initCompactionIfNecessary. + + 0 to: manager numSegments - 1 do: + [:i | + segInfo := self addressOf: (manager segmentManager segments at: i). + (self isSegmentBeingCompacted: segInfo) + ifTrue: [currentSegment := i. + currentHeapPointer := self compactSegment: segInfo freeStart: currentHeapPointer segIndex: i. + self assert: (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize))]]. + + self postCompactionAction. + self finishCompaction.! Item was added: + ----- Method: SpurIncrementalCompactor>>computeSegmentsToCompact (in category 'compaction planning') ----- + computeSegmentsToCompact + "Compute segments to compact: least occupied. + Answers true if compaction should be done + (at least 1 segment is being compacted and + there is a segment to compact into)." + | canStillClaim aboutToClaim aboutToClaimSegment atLeastOneSegmentToCompact | + <var: 'aboutToClaimSegment' type: #'SpurSegmentInfo *'> + atLeastOneSegmentToCompact := false. + aboutToClaimSegment := self findNextSegmentToCompact. + "Segment to fill is one of the segment compacted last GC. + If no segment were compacted last GC, and that there is + at least one segment to compact, allocate a new one." + aboutToClaimSegment ifNil: [^false]. + segmentToFill ifNil: + [self findOrAllocateSegmentToFill. + segmentToFill ifNil: ["Abort compaction"^false]]. + canStillClaim := segmentToFill segSize - manager bridgeSize. + [aboutToClaimSegment ifNil: [^atLeastOneSegmentToCompact]. + aboutToClaim := self sizeClaimedIn: aboutToClaimSegment. + aboutToClaim < canStillClaim ] whileTrue: + [self markSegmentAsBeingCompacted: aboutToClaimSegment. + atLeastOneSegmentToCompact := true. + canStillClaim := canStillClaim - aboutToClaim. + aboutToClaimSegment := self findNextSegmentToCompact]. + ^atLeastOneSegmentToCompact! Item was added: + ----- Method: SpurIncrementalCompactor>>doIncrementalCompact (in category 'incremental compaction') ----- + doIncrementalCompact + + <inline: #never> + | segInfo | + currentSegment to: manager numSegments - 1 do: + [:i | + segInfo := self addressOf: (manager segmentManager segments at: i). + (self isSegmentBeingCompacted: segInfo) + ifTrue: [currentSegment := i. + + coInterpreter cr; + print: 'Compact from: '; printHex: segInfo segStart; + print: ' to: '; printHex: segInfo segStart + segInfo segSize; + print: ' into: ' ; printHex: segmentToFill segStart; tab; flush. + + currentHeapPointer := self compactSegment: segInfo freeStart: currentHeapPointer segIndex: i. + self assert: manager totalFreeOldSpace = manager totalFreeListBytes. + self assert: (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize)). + + coInterpreter cr; + print: 'Pointer now: '; printHex: currentHeapPointer; tab; flush. + + self flag: #Todo. "for now we compact one segment at a time" + ^ currentSegment = (manager numSegments - 1) + ifTrue: [true] + ifFalse: [false]]]. + ^ true! Item was added: + ----- Method: SpurIncrementalCompactor>>findAndSetSegmentToFill (in category 'segment to fill') ----- + findAndSetSegmentToFill + | segInfo | + <var: 'segInfo' type: #'SpurSegmentInfo *'> + 0 to: manager numSegments - 1 do: + [:i| + segInfo := self addressOf: (manager segmentManager segments at: i). + (self segmentIsEmpty: segInfo) + ifTrue: [segmentToFill := segInfo. ^i]]. + ^-1! Item was added: + ----- Method: SpurIncrementalCompactor>>findNextSegmentToCompact (in category 'compaction planning') ----- + findNextSegmentToCompact + "Answers the next segment to compact or nil if none. + The next segment to compact: + - cannot be segment 0 (Segment 0 has specific objects + (nil, true, etc.) and special size computed at start-up + that we don't want to deal with) + - cannot have a high occupation rate (> MaxOccupationForCompaction)" + | leastOccupied leastOccupiedSegment tempOccupied segInfo | + <var: 'segInfo' type: #'SpurSegmentInfo *'> + leastOccupied := 16rFFFF. + 1 to: manager numSegments - 1 do: + [:i| + segInfo := self addressOf: (manager segmentManager segments at: i). + (self cannotBeCompacted: segInfo) + ifFalse: + [(tempOccupied := self occupationOf: segInfo) <= leastOccupied + ifTrue: [ leastOccupied := tempOccupied. + leastOccupiedSegment := segInfo ]]]. + leastOccupied > MaxOccupationForCompaction ifTrue: + [^self cCoerceSimple: nil to: #'SpurSegmentInfo *']. + ^leastOccupiedSegment! Item was added: + ----- Method: SpurIncrementalCompactor>>findOrAllocateSegmentToFill (in category 'segment to fill') ----- + findOrAllocateSegmentToFill + "There was no compacted segments from past GC that we can directly re-use. + We need either to find an empty segment or allocate a new one." + | segIndex | + "segment was already set from freePastSegmentsAndSetSegmentToFill at the end of the last markingpass. No need to do something. " + segmentToFill ifNotNil: [^0]. + + self findAndSetSegmentToFill. + segmentToFill ifNotNil: [self reserveSegmentToFill. ^0]. + + "No empty segment. We need to allocate a new one" + (manager growOldSpaceByAtLeast: manager growHeadroom) ifNil: ["failed to allocate"^0]. + + "We don't know which segment it is that we've just allocated... So we look for it... This is a bit dumb." + segIndex := self findAndSetSegmentToFill. + self assert: segmentToFill ~~ nil. + self reserveSegmentToFill! Item was added: + ----- Method: SpurIncrementalCompactor>>finishCompaction (in category 'incremental compaction') ----- + finishCompaction + + self resetCompactor! Item was added: + ----- Method: SpurIncrementalCompactor>>freePastSegmentsAndSetSegmentToFill (in category 'api') ----- + freePastSegmentsAndSetSegmentToFill + "The first segment being claimed met becomes the segmentToFill. The others are just freed." + | segInfo | + <var: 'segInfo' type: #'SpurSegmentInfo *'> + 0 to: manager numSegments - 1 do: + [:i| + segInfo := self addressOf: (manager segmentManager segments at: i). + (self isSegmentBeingCompacted: segInfo) + ifTrue: + [ | freeChunk chunkBytes | + chunkBytes := segInfo segSize - manager bridgeSize. + freeChunk := manager + addFreeChunkWithBytes: chunkBytes + at: segInfo segStart. + segmentToFill + ifNil: [manager detachFreeObject: freeChunk. + segmentToFill := segInfo]]]! Item was added: + ----- Method: SpurIncrementalCompactor>>incrementalCompact (in category 'incremental compaction') ----- + incrementalCompact + + segmentToFill + ifNotNil: [ + self assert: (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize)). + (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize)) + ifFalse: [self cCode: 'raise(SIGINT)']]. + + self initCompactionIfNecessary. + + segmentToFill + ifNotNil: [ + self assert: (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize))]. + + shouldCompact + ifTrue: [ | finishedCompacting | + finishedCompacting := self doIncrementalCompact. + + segmentToFill + ifNotNil: [self assert: (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize))]. + + self postCompactionAction. + + segmentToFill + ifNotNil: [self assert: (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize))]. + + finishedCompacting + ifTrue: [ + self finishCompaction. + ^ true]] + ifFalse: [self resetCompactor. ^ true "nothing to compact => we are finished"]. + + ^ false! Item was added: + ----- Method: SpurIncrementalCompactor>>initCompactionIfNecessary (in category 'incremental compaction') ----- + initCompactionIfNecessary + + isCompacting + ifFalse: [self assertNoSegmentBeingCompacted. + self planCompactionAndReserveSpace. + + self assert: manager totalFreeOldSpace = manager totalFreeListBytes. + + shouldCompact ifTrue: [ + coInterpreter cr; print: 'set the current heap pointer'; tab; flush. + currentHeapPointer := segmentToFill segStart]. + isCompacting := true. + self assert: currentSegment = 0]. + + + ! Item was added: + ----- Method: SpurIncrementalCompactor>>initialize (in category 'initialize-release') ----- + initialize + + isCompacting := false. + currentSegment := 0. + shouldCompact := false. + currentHeapPointer := 0! Item was added: + ----- Method: SpurIncrementalCompactor>>isSegmentBeingCompacted: (in category 'testing') ----- + isSegmentBeingCompacted: segInfo + <var: 'segInfo' type: #'SpurSegmentInfo *'> + "Swizzle is abused bit 16 isBeingCompacted bits 0-15 occupation" + ^ segInfo swizzle anyMask: 1 << 16! Item was added: + ----- Method: SpurIncrementalCompactor>>markSegmentAsBeingCompacted: (in category 'segment access') ----- + markSegmentAsBeingCompacted: segInfo + <var: 'segInfo' type: #'SpurSegmentInfo *'> + "Swizzle is abused bit 16 isBeingCompacted bits 0-15 occupation" + segInfo swizzle: (segInfo swizzle bitOr: 1 << 16)! Item was added: + ----- Method: SpurIncrementalCompactor>>migrate:sized:to: (in category 'as yet unclassified') ----- + migrate: obj sized: bytesToCopy to: address + + | copy | + self assert: (manager isPinned: obj) not. + + manager memcpy: address asVoidPointer _: (manager startOfObject: obj) asVoidPointer _: bytesToCopy. + + copy := manager objectStartingAt: address. + (manager isRemembered: copy) ifTrue: + ["copy has the remembered bit set, but is not in the remembered table." + manager setIsRememberedOf: copy to: false. + scavenger remember: copy]. + + manager forward: obj to: (manager objectStartingAt: address). + + ^ copy! Item was added: + ----- Method: SpurIncrementalCompactor>>occupationOf: (in category 'segment access') ----- + occupationOf: segInfo + <var: 'segInfo' type: #'SpurSegmentInfo *'> + "Swizzle is abused bit 16 isBeingCompacted bits 0-15 occupation" + ^segInfo swizzle bitAnd: 16rFFFF! Item was added: + ----- Method: SpurIncrementalCompactor>>planCompactionAndReserveSpace (in category 'compaction planning') ----- + planCompactionAndReserveSpace + + shouldCompact := self computeSegmentsToCompact + + ! Item was added: + ----- Method: SpurIncrementalCompactor>>postCompactionAction (in category 'as yet unclassified') ----- + postCompactionAction + | allFlags | + "For now we don't optimize and just follow everything everywhere on stack and in caches, let's see in the profiler if we need to optimize with those cases. My guess is that this is < 100 microSecond" + manager followSpecialObjectsOop. + allFlags := BecamePointerObjectFlag + BecameActiveClassFlag bitOr: BecameCompiledMethodFlag. + "Note: there is not the OldBecameNewFlag" + "gcMode flag is cleared after postBecomeAction, reset it." + manager coInterpreter postBecomeAction: allFlags. + manager coInterpreter setGCMode: GCModeFull. + + "Special to selective, crazy objects can be forwarded..." + "manager postBecomeScanClassTable: allFlags. => Done in followClassTable" + manager followClassTable. + manager followProcessList. + manager followForwardedObjStacks. + + "Not sure the following are needed... + coInterpreter mapInterpreterOops. + manager mapExtraRoots." + self assert: manager validClassTableHashes.! Item was added: + ----- Method: SpurIncrementalCompactor>>postSwizzleAction (in category 'api') ----- + postSwizzleAction + "Since the compact abuses the swizzle field of segment, it needs to be reset after start-up." + + | segInfo | + <var: 'segInfo' type: #'SpurSegmentInfo *'> + 0 to: manager numSegments - 1 do: + [:i| + segInfo := self addressOf: (manager segmentManager segments at: i). + segInfo swizzle: 0 ]! Item was added: + ----- Method: SpurIncrementalCompactor>>reserveSegmentToFill (in category 'segment access') ----- + reserveSegmentToFill + "remove the free space from the freeLists so the mutator cannot allocate in this segment" + + | freeChunk | + self assert: segmentToFill notNil. + self assert: (self segmentIsEmpty: segmentToFill). + + freeChunk := manager objectStartingAt: segmentToFill segStart. + manager detachFreeObject: freeChunk! Item was added: + ----- Method: SpurIncrementalCompactor>>resetCompactor (in category 'as yet unclassified') ----- + resetCompactor + + self setFreeChunkOfCompactedIntoSegment. + + isCompacting := false. + shouldCompact := false. + currentHeapPointer := 0. + currentSegment := 0! Item was added: + ----- Method: SpurIncrementalCompactor>>segmentIsEmpty: (in category 'testing') ----- + segmentIsEmpty: segInfo + "a free segment contains only a free chunk and a bridge (every segment ends in one of these)" + + ^ manager segmentManager isEmptySegment: segInfo + + ! Item was added: + ----- Method: SpurIncrementalCompactor>>segmentToFill (in category 'as yet unclassified') ----- + segmentToFill + + <cmacro: '() GIV(segmentToFill)'> + ^ segmentToFill! Item was added: + ----- Method: SpurIncrementalCompactor>>setFreeChunkOfCompactedIntoSegment (in category 'segment access') ----- + setFreeChunkOfCompactedIntoSegment + + shouldCompact ifFalse: [^ self]. + + self assert: segmentToFill notNil. + self assert: (self oop: currentHeapPointer isLessThan: (segmentToFill segLimit - manager bridgeSize)). + + manager + addFreeChunkWithBytes: segmentToFill segSize - manager bridgeSize + segmentToFill segStart - currentHeapPointer + at: currentHeapPointer. + + "we have compacted into segmentToFill. It is now not empty anymore and we need to look for a new one" + shouldCompact + ifTrue: [segmentToFill := nil] + ! Item was added: + ----- Method: SpurIncrementalCompactor>>sizeClaimedIn: (in category 'segment access') ----- + sizeClaimedIn: segment + <var: 'segment' type: #'SpurSegmentInfo *'> + <var: 'ratio' type: #'double'> + "careful with overflow here" + "roundedup used ratio (+1 to round up)" + | ratio | + ratio := ((self occupationOf: segment) + 1) asFloat / 16rFFFF. + ^(ratio * (segment segSize - manager bridgeSize)) asInteger ! Item was added: + SpurGarbageCollector subclass: #SpurIncrementalGarbageCollector + instanceVariableNames: 'phase allAtOnceMarker checkSetGCFlags' + classVariableNames: 'InCompactingPhase InMarkingPhase InSweepingPhase' + poolDictionaries: '' + category: 'VMMaker-SpurGarbageCollector'! Item was added: + ----- Method: SpurIncrementalGarbageCollector class>>classesForTranslation (in category 'translation') ----- + classesForTranslation + + ^ super classesForTranslation , {SpurMarker . SpurIncrementalMarker . SpurAllAtOnceMarker . SpurPlanningCompactor . SpurIncrementalSweeper . SpurIncrementalCompactor . SpurIncrementalSweepAndCompact }! Item was added: + ----- Method: SpurIncrementalGarbageCollector class>>compactorClass (in category 'accessing class hierarchy') ----- + compactorClass + + ^ SpurIncrementalSweepAndCompact! Item was added: + ----- Method: SpurIncrementalGarbageCollector class>>declareCVarsIn: (in category 'translation') ----- + declareCVarsIn: aCCodeGenerator + + super declareCVarsIn: aCCodeGenerator. + aCCodeGenerator var: 'phase' declareC: 'sqInt phase = 0'. + + aCCodeGenerator + staticallyResolvedPolymorphicReceiver: 'marker' to: self markerClass; + staticallyResolvedPolymorphicReceiver: 'allAtOnceMarker' to: SpurAllAtOnceMarker! Item was added: + ----- Method: SpurIncrementalGarbageCollector class>>initialize (in category 'initialization') ----- + initialize + + InMarkingPhase := 0. + InSweepingPhase := 1. + InCompactingPhase := 2.! Item was added: + ----- Method: SpurIncrementalGarbageCollector class>>markerClass (in category 'accessing class hierarchy') ----- + markerClass + + ^ SpurIncrementalMarker! Item was added: + ----- Method: SpurIncrementalGarbageCollector class>>simulatorClass (in category 'simulation') ----- + simulatorClass + + "^ SpurIncrementalGarbageCollectorSimulator" + ^ self! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>IsMarkingValidForWeaklings (in category 'testing') ----- + IsMarkingValidForWeaklings + "during marking we do not know if an objects will get marked. As long as we did not finish marking do not + clean weak slots of weak objects" + + ^ self isMarking not! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>assertSettingGCFlagsIsOk: (in category 'as yet unclassified') ----- + assertSettingGCFlagsIsOk: objOop + + checkSetGCFlags ifFalse: [^ self]. + + "do not color young objects. They have an extra state we do not want to change" + self assert: (manager isOldObject: objOop). + (manager isOldObject: objOop) + ifFalse: [self cCode: 'raise(SIGINT)']. + + "while sweeping: do not color objects behind the currently point the sweeper is at. This would infer with the next marking pass" + self assert: (self allocatorShouldAllocateBlack not or: [objOop >= self compactor currentSweepingEntity]). + + (self allocatorShouldAllocateBlack not or: [objOop >= self compactor currentSweepingEntity]) + ifFalse: [self cCode: 'error("foo")'.]! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>doIncrementalCollect (in category 'as yet unclassified') ----- + doIncrementalCollect + + phase = InMarkingPhase + ifTrue: [ | finishedMarking | + marker isCurrentlyMarking + ifFalse: [self assert: manager allObjectsUnmarked.]. + + coInterpreter cr; print: 'start marking '; tab; flush. + finishedMarking := marker incrementalMarkObjects. + + "self assert: manager validObjectColors." + + finishedMarking + ifTrue: [ + manager allPastSpaceObjectsDo: [:obj | self assert: (manager isWhite: obj)]. + + "when sweeping the mutator needs to allocate new objects black as we do not have any information about them. + We only know if they should get swept after the next marking -> keep them alive for this cycle" + self allocatorShouldAllocateBlack: true. + compactor setInitialSweepingEntity. + phase := InSweepingPhase. + + "marking is done and thus all forwarding from the last compaction references are resolved + -> we can use the now free segments that were compacted during the last cycle" + compactor freePastSegmentsAndSetSegmentToFill. + + coInterpreter cr; print: 'finish marking '; tab; flush. + + manager + setCheckForLeaks: GCCheckFreeSpace + GCModeFull; + runLeakCheckerFor: GCModeFull excludeUnmarkedObjs: true classIndicesShouldBeValid: true; + checkFreeSpace: GCModeFull. + + + ^ self] + ifFalse: [coInterpreter cr; print: 'finish marking pass'; tab; flush.manager runLeakCheckerFor: GCModeIncremental]]. + + phase = InSweepingPhase + ifTrue: [ + coInterpreter cr; print: 'start sweeping '; tab; flush. + compactor incrementalSweep + ifTrue: [ + self allocatorShouldAllocateBlack: false. + manager allOldSpaceObjectsDo: [:ea | self assert: (manager isWhite: ea) ]. + "self assert: manager allObjectsUnmarked." + + coInterpreter cr; print: 'finish sweeping '; tab; flush. + + manager + setCheckForLeaks: GCCheckFreeSpace + GCModeFull; + runLeakCheckerFor: GCModeFull; + checkFreeSpace: GCModeFull. + + compactor assertNoSegmentBeingCompacted. + + phase := InCompactingPhase. + ^ self]]. + + phase = InCompactingPhase + ifTrue: [ + "self cCode: 'raise(SIGINT)'." + coInterpreter cr; print: 'start compacting '; tab; flush. + compactor incrementalCompact + ifTrue: [ + coInterpreter cr; print: 'finish compacting '; tab; flush. + manager + setCheckForLeaks: GCCheckFreeSpace + GCModeFull; + runLeakCheckerFor: GCModeFull; + checkFreeSpace: GCModeFull. + + phase := InMarkingPhase. + + ^ self]]! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>finishGCPass (in category 'as yet unclassified') ----- + finishGCPass + + self assert: manager validObjStacks. + + coInterpreter cr; print: 'finish gc pass '; tab; flush. + + coInterpreter setGCMode: GCModeNewSpace. + self doScavengeWithoutIncrementalCollect: MarkOnTenure. + + coInterpreter setGCMode: GCModeIncremental. + phase = InMarkingPhase + ifTrue: [ + "end marking" + [phase = InMarkingPhase] + whileTrue: [self doIncrementalCollect]]. + + "end this collection cycle" + [phase ~= InMarkingPhase] + whileTrue: [self doIncrementalCollect]! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>fullGC (in category 'global') ----- + fullGC + "We need to be able to make a full GC, e.g. when we save the image. Use the made progress and finish the collection" + + "incredible hacky solution. Will later on be replaced with the old collection, but for now use this to keep the state transitions consistent" + + self assert: manager validObjStacks. + + coInterpreter cr; print: 'start fullGC '; tab; flush. + + coInterpreter setGCMode: GCModeNewSpace. + self doScavengeWithoutIncrementalCollect: MarkOnTenure. + + coInterpreter setGCMode: GCModeIncremental. + phase = InMarkingPhase + ifTrue: [ + "end marking" + [phase = InMarkingPhase] + whileTrue: [self doIncrementalCollect]]. + + "end this collection cycle" + [phase ~= InMarkingPhase] + whileTrue: [self doIncrementalCollect]. + + "resolve forwarders in young space" + coInterpreter setGCMode: GCModeNewSpace. + self doScavengeWithoutIncrementalCollect: MarkOnTenure. + + coInterpreter setGCMode: GCModeIncremental. + + "mark completely" + [phase = InMarkingPhase] + whileTrue: [self doIncrementalCollect]. + "do rest of collection" + [phase ~= InMarkingPhase] + whileTrue: [self doIncrementalCollect]. + + manager setHeapSizeAtPreviousGC. + + coInterpreter cr; print: 'end fullGC '; tab; flush. + + ^(manager freeLists at: 0) ~= 0 + ifTrue: [manager bytesInBody: manager findLargestFreeChunk] + ifFalse: [0]! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>inSweepingAheadOfSweepersPosition: (in category 'testing') ----- + inSweepingAheadOfSweepersPosition: objOop + + ^ self isSweeping and: [objOop >= compactor currentSweepingEntity]! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>incrementalCollect (in category 'global') ----- + incrementalCollect + + self flag: #Todo. "where to put this?" + manager statScavenges = 0 ifTrue: [manager makeAllObjectsWhite.]. + self doIncrementalCollect. + + self assert: manager validObjStacks.! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>initialize (in category 'initialize-release') ----- + initialize + + super initialize. + + checkSetGCFlags := true. + phase := InMarkingPhase. + allAtOnceMarker := SpurAllAtOnceMarker new! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>isCompacting (in category 'testing') ----- + isCompacting + + ^ phase = InCompactingPhase! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>isIncremental (in category 'testing') ----- + isIncremental + + ^ true! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>isMarking (in category 'testing') ----- + isMarking + + ^ phase = InMarkingPhase! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>isOkToClearReference: (in category 'testing') ----- + isOkToClearReference: objOop + "when using incremental GC if an object is life is only possible to determine in a small time window (in sweeping for objects behind the sweepers position). During marking the information is not complete and in compaction the mark bits are already cleared. For simlicity, forbid clearing them. + Now only at the end of marking weak references and ephermerons get cleared (in old and young space)" + + ^ (manager isOldObject: objOop) not! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>isOkToDeleteSegment: (in category 'testing') ----- + isOkToDeleteSegment: segment + + ^ segment ~= compactor segmentToFill! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>isOkToScavengeRememberedObject: (in category 'testing') ----- + isOkToScavengeRememberedObject: objOop + "When sweeping we can alreay have freed an object A that is referenced by B. If B is behind the sweepers + position and not marked it is garbage and to be collected. Yet B is still in the remembered set and will get + scanned, during which the freed object will be visited an an error caused. Use this check to prevent this" + + ^ (phase = InSweepingPhase + and: [objOop >= compactor currentSweepingEntity + and: [(manager isMarked: objOop) not]]) not! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>isSweeping (in category 'testing') ----- + isSweeping + + ^ phase = InSweepingPhase! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>markObjects: (in category 'as yet unclassified') ----- + markObjects: objectsShouldBeUnmarkedAndUnmarkedClassesShouldBeExpunged + + self flag: #Todo. "write more efficient version" + + coInterpreter setGCMode: GCModeNewSpace. + self doScavengeWithoutIncrementalCollect: MarkOnTenure. + + phase = InMarkingPhase + ifTrue: [ + "end marking" + [phase = InMarkingPhase] + whileTrue: [self doIncrementalCollect]]. + + "end this collection cycle" + [phase ~= InMarkingPhase] + whileTrue: [self doIncrementalCollect]. + + "resolve forwarders in young space" + coInterpreter setGCMode: GCModeNewSpace. + self doScavengeWithoutIncrementalCollect: MarkOnTenure. + + "mark completely" + [phase = InMarkingPhase] + whileTrue: [self doIncrementalCollect].! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>markObjectsCompletely (in category 'as yet unclassified') ----- + markObjectsCompletely + "use the all at once marker to mark objects in young space too (normal incremental marking would not do so) + make sure to unmark objects in young space afterwards!! The correctness of the algorithm depends on it" + + checkSetGCFlags := false. + allAtOnceMarker markersMarkObjects: false. + checkSetGCFlags := true! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>markObjectsForEnumerationPrimitives (in category 'as yet unclassified') ----- + markObjectsForEnumerationPrimitives + + "do we need marking complete (and more accurate than incremental marking provides). For now lets do this only during marking although + probaly not 100% correct" + self flag: #Todo. "rework later on" + ^ phase = InMarkingPhase! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>maybeModifyCopiedObject: (in category 'object creation barriers') ----- + maybeModifyCopiedObject: objOop + + "1. when marking always mark as we already could have marked all objects pointing to objOop + 2. during sweeping mark objects behind the sweepers current position so it does not collect objOop" + + (manager isOldObject: objOop) + ifTrue: [ + phase = InMarkingPhase + ifTrue: [ + "If the object is not white we would skip it. Therefore make sure it is, as all young space objects + should be" + self assert: (manager isWhite: objOop). + + "do not just color it but handle it correctly, depending on which type of object it is and + do things like scanning its class" + marker markAndShouldScan: objOop]. + + (self inSweepingAheadOfSweepersPosition: objOop) + ifTrue: [manager setIsMarkedOf: objOop to: true]]! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>maybeModifyForwarder: (in category 'object creation barriers') ----- + maybeModifyForwarder: objOop + + "mark forwarders so they do not get garbage collected before they can get resolved. + 1. Does only apply to marking because only in this phase we can overlook forwarding references to be resolved (e.g. when + the mutator runs after the first marking pass and an object that is referenced by at least one already black object gets a forwarded -> the pointer of the black object won't get updated in this marking pass and during sweeping the forwarding pointer will get removed). + 2. Does not apply to sweeping or compacting because the forwarder is set on the header of the original object, which already includes + the correcty set mark bit" + self assert: (manager isForwarded: objOop). + ((manager isOldObject: objOop) and: [phase = InMarkingPhase]) + ifTrue: [manager setIsMarkedOf: objOop to: true]! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>maybeModifyGCFlagsOf: (in category 'object creation barriers') ----- + maybeModifyGCFlagsOf: objOop + + "when allocating a new object behind the current sweeping hight mark it should be allocated black so it does not get garbage + collected although we do not know if this is correct" + <inline: true> + ((manager isOldObject: objOop) and: [self inSweepingAheadOfSweepersPosition: objOop]) + ifTrue: [manager setIsMarkedOf: objOop to: true]! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>phase (in category 'accessing') ----- + phase + + ^ phase! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>phase: (in category 'accessing') ----- + phase: anObject + + phase := anObject.! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>sufficientSpaceAfterGC: (in category 'as yet unclassified') ----- + sufficientSpaceAfterGC: numBytes + + | heapSizePostGC | + self assert: numBytes = 0. + self scavengingGCTenuringIf: TenureByAge. + heapSizePostGC := manager segmentManager totalOldSpaceCapacity - manager totalFreeOldSpace. + (heapSizePostGC - manager heapSizeAtPreviousGC) asFloat / manager heapSizeAtPreviousGC >= manager heapGrowthToSizeGCRatio + ifTrue: ["self fullGC"] "fullGC will attempt to shrink" + ifFalse: "Also attempt to shrink if there is plenty of free space and no need to GC" + [manager totalFreeOldSpace > (manager shrinkThreshold * 2) ifTrue: + [manager attemptToShrink. + ^true]]. + [manager totalFreeOldSpace < manager growHeadroom + and: [(manager growOldSpaceByAtLeast: 0) notNil]] whileTrue: + [manager totalFreeOldSpace >= manager growHeadroom ifTrue: + [^true]]. + manager lowSpaceThreshold > manager totalFreeOldSpace ifTrue: "space is low" + [manager lowSpaceThreshold: 0. "avoid signalling low space twice" + ^false]. + ^true! Item was added: + SpurIncrementalGarbageCollector subclass: #SpurIncrementalGarbageCollectorSimulator + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'VMMaker-SpurGarbageCollectorSimulation'! Item was added: + ----- Method: SpurIncrementalGarbageCollectorSimulator>>doIncrementalCollect (in category 'as yet unclassified') ----- + doIncrementalCollect + + | context | + manager statScavenges \\ 50 = 0 ifTrue: [GCEventLog reset]. + "(manager statScavenges > 218 and: [phase = InSweepingPhase]) ifTrue: [self halt]." + "manager statScavenges = 320 ifTrue: [self halt]." + + "pop mutator context" + context := GCEventLog instance popContext. + self assert: (context kind = #mutator or: [context kind = #fullGC]). + super doIncrementalCollect. + + context kind = #fullGC + ifTrue: [GCEventLog instance pushContext: context] + ifFalse: [GCEventLog instance pushMutatorContext] + ! Item was added: + ----- Method: SpurIncrementalGarbageCollectorSimulator>>fullGC (in category 'global') ----- + fullGC + + GCEventLog + inContext: #fullGC + do: [super fullGC]! Item was added: + ----- Method: SpurIncrementalGarbageCollectorSimulator>>initialize (in category 'initialize-release') ----- + initialize + + super initialize. + GCEventLog reset! Item was added: + ----- Method: SpurIncrementalGarbageCollectorSimulator>>manager: (in category 'accessing') ----- + manager: manager + + super manager: manager. + GCEventLog instance manager: manager! Item was added: + SpurMarker subclass: #SpurIncrementalMarker + instanceVariableNames: 'isCurrentlyMarking' + classVariableNames: 'SlotLimitPerPass' + poolDictionaries: '' + category: 'VMMaker-SpurGarbageCollector'! Item was added: + ----- Method: SpurIncrementalMarker class>>initialize (in category 'as yet unclassified') ----- + initialize + + "experimental value. needs some measurements" + SlotLimitPerPass := 10 * 1024 * 1024! Item was added: + ----- Method: SpurIncrementalMarker class>>simulatorClass (in category 'as yet unclassified') ----- + simulatorClass + + "^ SpurIncrementalMarkerSimulation" + ^ self! Item was added: + ----- Method: SpurIncrementalMarker>>allReferencedClassesAreMarked (in category 'testing') ----- + allReferencedClassesAreMarked + + manager allObjectsDo: [:obj | + ((manager isMarked: obj) or: [(manager isNonImmediate: obj) and: [manager isYoung: obj]]) + ifTrue: [ | unmarkedClass | + self flag: #Todo. "change name. The grey part seems to be off" + unmarkedClass := self allReferencedClassesAreMarkedOrGreyFrom: obj lastObj: -1. + + unmarkedClass ~= -1 + ifTrue: [coInterpreter cr; print: 'class not marked '; tab; flush. + coInterpreter longPrintOop: unmarkedClass. + coInterpreter cr; print: 'referenced by: '; tab; flush. + coInterpreter longPrintOop: obj. + + (manager isYoung: obj) + ifTrue: [coInterpreter cr; print: 'young '; tab; flush.] + ifFalse: [coInterpreter cr; print: 'old'; tab; flush.]. + ^ false]]]. + + ^ true! Item was added: + ----- Method: SpurIncrementalMarker>>allReferencedClassesAreMarkedFrom:lastObj: (in category 'testing') ----- + allReferencedClassesAreMarkedFrom: objOop lastObj: lastObj + + | classIndex classObj | + classIndex := manager classIndexOf: objOop. + classObj := manager classOrNilAtIndex: classIndex. + + (manager isMarked: classObj) + ifFalse: [^ classObj]. + + ^ lastObj = classObj + ifTrue: [-1] + ifFalse: [self allReferencedClassesAreMarkedFrom: classObj lastObj: objOop]! Item was added: + ----- Method: SpurIncrementalMarker>>allReferencedClassesAreMarkedOrGreyFrom:lastObj: (in category 'testing') ----- + allReferencedClassesAreMarkedOrGreyFrom: objOop lastObj: lastObj + + | obj classIndex classObj | + obj := objOop. + (manager isForwarded: objOop) + ifTrue: [obj := manager followForwarded: objOop.]. + + classIndex := manager classIndexOf: obj. + classObj := manager classOrNilAtIndex: classIndex. + + ((manager isWhite: classObj) and: [manager isOldObject: classObj]) + ifTrue: [self halt. ^ classObj]. + + ^ lastObj = classObj + ifTrue: [-1] + ifFalse: [self allReferencedClassesAreMarkedOrGreyFrom: classObj lastObj: obj]! Item was added: + ----- Method: SpurIncrementalMarker>>blackenObject: (in category 'as yet unclassified') ----- + blackenObject: obj + + self flag: #Todo. "do we need to ungrey the object or can we save the call? Idea: + -> if grey set -> grey + -> if mark set -> ignore grey, interpret it as black" + manager setIsGreyOf: obj to: false. + manager setIsMarkedOf: obj to: true! Item was added: + ----- Method: SpurIncrementalMarker>>collectWeaklingsFromYoungSpaceInWeakSet (in category 'as yet unclassified') ----- + collectWeaklingsFromYoungSpaceInWeakSet + + manager allNewSpaceObjectsDo: [:objOop | + ((manager isNonImmediate: objOop) and: [manager isWeak: objOop]) + ifTrue: [manager push: objOop onObjStack: manager weaklingStack]]! Item was added: + ----- Method: SpurIncrementalMarker>>completeMark (in category 'marking - global') ----- + completeMark + "finishes the current mark pass" + + | currentObj slotsLeft | + "manager objStack: manager markStack do: [:index :page | Transcript showln: (manager fetchPointer: index ofObject: page)]. + manager sizeOfObjStack: manager markStack" + currentObj := manager popObjStack: manager markStack. + currentObj + ifNil: [^ true]. "there is nothing more on the stack and we are done" + + slotsLeft := SlotLimitPerPass. + + [ + | slotNumber slotsToVisit startIndex | + + "after passing the limit we push the current index on the stack. Is the currentObj only an index? " + (manager isImmediate: currentObj) + ifTrue: [startIndex := currentObj. + currentObj := manager popObjStack: manager markStack.] + ifFalse: [startIndex := 0]. + + self markAndTraceClassOf: currentObj. + + slotNumber := manager numStrongSlotsOfInephemeral: currentObj. + slotsToVisit := slotNumber - startIndex. + + "we can mark all" + slotsLeft := slotsLeft - slotsToVisit. + + self markFrom: startIndex nSlots: slotsToVisit of: currentObj. + + "we finished everything there is to be done with to obj -> make it black" + self blackenObject: currentObj. + currentObj := manager popObjStack: manager markStack. + "repeat while there still are objects" + currentObj notNil] whileTrue. + + ^ true! Item was added: + ----- Method: SpurIncrementalMarker>>completeMarkObjects (in category 'marking - global') ----- + completeMarkObjects + "this method is meant to be run for a complete GC that is used for snapshots. It discards previous marking information, because + this will probably include some objects that should be collected + It makes me a bit sad but I cannot see how this could be avoided" + + <inline: #never> "for profiling" + coInterpreter cr; print: 'completeMarkObjects '; tab; flush. + "reset and reinitialize all helper structures and do actions to be done at the start of marking" + manager shutDownGlobalIncrementalGC: true. + self resetMarkProgress. + self initForNewMarkingPassIfNecessary. + + self pushAllRootsOnMarkStack. + self completeMark. + + self finishMarking. + + manager gc compactor setInitialSweepingEntity. + manager gc compactor freePastSegmentsAndSetSegmentToFill. + + manager runLeakCheckerFor: GCModeFull. + + ! Item was added: + ----- Method: SpurIncrementalMarker>>finishMarking (in category 'as yet unclassified') ----- + finishMarking + "marks the structures needed during GC" + <inline: #never> + + "lets assume there are not too many for now" + self markWeaklingsAndMarkAndFireEphemerons. + "self assert: self allReferencedClassesAreMarked." + self allReferencedClassesAreMarked not + ifTrue: [self cCode: 'raise(SIGINT)']. + manager expungeDuplicateAndUnmarkedClasses: true ignoringClassesInYoungSpace: true. + + "Young space weaklings are not included in the weak set here. If weaklings from young space contain references to + old space and the object behind it gets freed during sweeping a scavenge can try to access such an object. Therefore + collect all young space weaklings here and nil their references (do it in the end to not include not existing weak objects + from previous marking passes" + self collectWeaklingsFromYoungSpaceInWeakSet. + manager nilUnmarkedWeaklingSlotsExcludingYoungObjects: true. + + self assert: (manager isEmptyObjStack: manager markStack). + + isCurrentlyMarking := false. + marking := false! Item was added: + ----- Method: SpurIncrementalMarker>>incrementalMark (in category 'marking - incremental') ----- + incrementalMark + "does one marking cycle. Breaks after a certain amount of slots is marked and the last object, that amount is crossed in, is completely scanned" + + | currentObj slotsLeft | + "manager objStack: manager markStack do: [:index :page | Transcript showln: (manager fetchPointer: index ofObject: page)]. + manager sizeOfObjStack: manager markStack" + currentObj := manager popObjStack: manager markStack. + "skip young objects. They get already scanned as they are part of the roots" + [(currentObj notNil) and: [(manager isNonImmediate: currentObj) and: [manager isYoung: currentObj]]] + whileTrue: [(manager isInClassTable: currentObj) ifTrue: [manager setIsMarkedOf: currentObj to: true]. + currentObj := manager popObjStack: manager markStack]. + + currentObj + ifNil: [^ true]. "there is nothing more on the stack and we are done" + + slotsLeft := SlotLimitPerPass. + + [ + | slotNumber slotsToVisit startIndex | + + "after passing the limit we push the current index on the stack. Is the currentObj only an index? " + (manager isImmediate: currentObj) + ifTrue: [startIndex := manager integerValueOf: currentObj. + currentObj := manager popObjStack: manager markStack.] + ifFalse: [startIndex := 0. + + self assert: (self isFreeObject: currentObj) not. + (manager isForwarded: currentObj) + ifTrue: [currentObj := manager followForwarded: currentObj]. + + + self markAndTraceClassOf: currentObj. + + "eager color the object black. Either it will get scanned completely and the color is correct + or we have at least scanned some of the slots. In the second case the mutator could + modify one of the slots of the object that already were scanned and we would could lose + this object. Therefore color the object early to trigger the write barrier on writes. There will + be some overhead (trigger the barrier always although only the already scanned slots are + technically black) but it seems we need to do this for correctness" + self blackenObject: currentObj]. + + slotNumber := manager numStrongSlotsOfInephemeral: currentObj. + slotsToVisit := slotNumber - startIndex. + + slotsLeft - slotsToVisit < 0 + ifTrue: [ + self + markFrom: startIndex + nSlots: slotsLeft + of: currentObj. + + "If we need to abort earlier we push the index and the currently scanned object on the marking stack. Otherwise it is not possible + for immediates to be on the stack (they have no fields to be scanned) -> we can use the immediated to detect this pattern" + (manager topOfObjStack: manager markStack) ~= currentObj ifTrue: + [manager push: currentObj onObjStack: manager markStack]. + manager push: (manager integerObjectOf: slotsLeft) onObjStack: manager markStack. + + "we need to abort early to not run into some extreme corner cases (giant objects) that would explode our mark time assumptions" + ^ false] + ifFalse: ["we can mark all" + slotsLeft := slotsLeft - slotsToVisit. + + self markFrom: startIndex nSlots: slotsToVisit of: currentObj]. + + currentObj := manager popObjStack: manager markStack. + + [(currentObj notNil) and: [(manager isNonImmediate: currentObj) and: [manager isYoung: currentObj]]] + whileTrue: [(manager isInClassTable: currentObj) ifTrue: [manager setIsMarkedOf: currentObj to: true]. + currentObj := manager popObjStack: manager markStack]. + "repeat while there still are objects" + currentObj notNil] whileTrue. + + ^ true! Item was added: + ----- Method: SpurIncrementalMarker>>incrementalMarkAndTrace: (in category 'marking - incremental') ----- + incrementalMarkAndTrace: objOop + + <api> + <inline: #never> + "if markAndTrace: is to follow and eliminate forwarding pointers + in its scan it cannot be handed an r-value which is forwarded. + The assert for this is in markAndShouldScan:" + (self markAndShouldScan: objOop) ifFalse: + [^self]. + + "Now scan the object, and any remaining objects on the mark stack." + self incrementalMarkFrom: objOop! Item was added: + ----- Method: SpurIncrementalMarker>>incrementalMarkFrom: (in category 'marking - incremental') ----- + incrementalMarkFrom: objOop + "does one marking cycle. Breaks after a certain amount of slots is marked and the last object, that amount is crossed in, is completely scanned" + + | currentObj slotsLeft | + "manager objStack: manager markStack do: [:index :page | Transcript showln: (manager fetchPointer: index ofObject: page)]. + manager sizeOfObjStack: manager markStack" + currentObj := objOop. + currentObj + ifNil: [^ true]. "there is nothing more on the stack and we are done" + + slotsLeft := SlotLimitPerPass. + + [ + | slotNumber slotsToVisit startIndex | + + "after passing the limit we push the current index on the stack. Is the currentObj only an index? " + (manager isImmediate: currentObj) + ifTrue: [startIndex := manager integerValueOf: currentObj. + currentObj := manager popObjStack: manager markStack.] + ifFalse: [startIndex := 0]. + + ((manager isYoung: currentObj) and: [manager isInClassTable: currentObj]) + ifTrue: [manager setIsMarkedOf: currentObj to: true]. + + slotNumber := manager numStrongSlotsOfInephemeral: currentObj. + slotsToVisit := slotNumber - startIndex. + + slotsLeft - slotsToVisit < 0 + ifTrue: [ + self + markFrom: startIndex + nSlots: slotsLeft + of: currentObj. + + "If we need to abort earlier we push the index and the currently scanned object on the marking stack. Otherwise it is not possible + for immediates to be on the stack (they have no fields to be scanned) -> we can use the immediated to detect this pattern" + (manager topOfObjStack: manager markStack) ~= currentObj ifTrue: + [manager push: currentObj onObjStack: manager markStack]. + manager push: (manager integerObjectOf: slotsLeft + 1) onObjStack: manager markStack. + + "we need to abort early to not run into some extreme corner cases (giant objects) that would explode our mark time assumptions" + ^ false] + ifFalse: ["we can mark all" + slotsLeft := slotsLeft - slotsToVisit. + + self markFrom: startIndex nSlots: slotsToVisit of: currentObj]. + + "we finished everything there is to be done with to obj -> make it black" + self blackenObject: currentObj. + currentObj := manager popObjStack: manager markStack. + "repeat while there still are objects" + currentObj notNil] whileTrue. + + ^ true! Item was added: + ----- Method: SpurIncrementalMarker>>incrementalMarkObjects (in category 'marking - incremental') ----- + incrementalMarkObjects + "this method is to be run directly after a scavenge -> we can assume there are ony objects in the now past survivor space" + + <inline: #never> "for profiling" + + "manager runLeakCheckerFor: GCModeIncremental." + + self initForNewMarkingPassIfNecessary. + + [ | continueMarking | + (manager isEmptyObjStack: manager markStack) + ifTrue: [self pushAllRootsOnMarkStack. + " manager sizeOfObjStack: manager markStack. + did we finish marking?" + (manager isEmptyObjStack: manager markStack) + ifTrue: [self finishMarking. + ^ true]]. + + + "due to a slang limitations we have to assign the result into variable => do not remove!!" + continueMarking := self incrementalMark. + continueMarking] whileTrue. + + ^ false + ! Item was added: + ----- Method: SpurIncrementalMarker>>initForNewMarkingPassIfNecessary (in category 'marking-initialization') ----- + initForNewMarkingPassIfNecessary + + isCurrentlyMarking + ifFalse: [ + manager initializeMarkStack. + manager initializeWeaklingStack. + manager initializeEphemeronStack. + + "This must come first to enable stack page reclamation. It clears + the trace flags on stack pages and so must precede any marking. + Otherwise it will clear the trace flags of reached pages." + coInterpreter initStackPageGC. + + self markHelperStructures. + + isCurrentlyMarking := true. + marking := true. + self pushInternalStructuresOnMarkStack]. + + ! Item was added: + ----- Method: SpurIncrementalMarker>>initialize (in category 'initialize-release') ----- + initialize + + super initialize. + isCurrentlyMarking := false. + marking := false! Item was added: + ----- Method: SpurIncrementalMarker>>isCurrentlyMarking (in category 'accessing') ----- + isCurrentlyMarking + + ^ isCurrentlyMarking! Item was added: + ----- Method: SpurIncrementalMarker>>isCurrentlyMarking: (in category 'accessing') ----- + isCurrentlyMarking: anObject + + isCurrentlyMarking := anObject.! Item was added: + ----- Method: SpurIncrementalMarker>>markAllUnscannedEphemerons (in category 'weaklings and ephemerons') ----- + markAllUnscannedEphemerons + "After firing the unscanned ephemerons we must scan-mark them. + The wrinkle is that doing so may add more ephemerons to the set. + So we remove the first element, by overwriting it with the last element, + and decrementing the top, and then markAndTrace its contents." + self assert: (manager isEmptyObjStack: manager ephemeronStack) not. + self assert: manager allUnscannedEphemeronsOnObjStackAreActive. + + [(manager isEmptyObjStack: manager ephemeronStack) not] whileTrue: + [| pointer ephemeron key | + pointer := manager popObjStack: manager ephemeronStack. + ephemeron := manager longAt: pointer. + + key := manager followedKeyOfMaybeFiredEphemeron: ephemeron. + manager setIsMarkedOf: ephemeron to: false. "to get it to be fully scanned in markAndTrace:" + self + incrementalMarkAndTrace: key; + incrementalMarkAndTrace: ephemeron]! Item was added: + ----- Method: SpurIncrementalMarker>>markAndShouldScan: (in category 'marking - incremental') ----- + markAndShouldScan: objOop + "marks the object (grey or black as neccessary) and returns if the object should be scanned + Objects that get handled later on get marked as black, as they are practically a leaf in the object tree (we scan them later on, so we cannot lose objects and do not + need to adhere to the tricolor invariant)" + + | format | + <inline: true> + (manager isYoung: objOop) + ifTrue: [^ false]. + + (manager isImmediate: objOop) ifTrue: + [^false]. + + self assert: (manager isForwarded: objOop) not. + + "if it is marked we already did everything we needed to do and if is grey we already saw it and do not have to do anything here" + (manager isWhite: objOop) not ifTrue: + [^false]. + + format := manager formatOf: objOop. + + (manager isPureBitsFormat: format) ifTrue: "avoid pushing non-pointer objects on the markStack." + ["Avoid tracing classes of non-objects on the heap, e.g. IRC caches, Sista counters." + (manager classIndexOf: objOop) > manager lastClassIndexPun ifTrue: + [self markAndTraceClassOf: objOop]. + + "the object does not need to enter the marking stack as there are no pointer to visit -> it is already finished and we can make it black" + self blackenObject: objOop. + ^false]. + + (manager isWeakFormat: format) ifTrue: "push weaklings on the weakling stack to scan later" + [manager push: objOop onObjStack: manager weaklingStack. + "do not follow weak references. They get scanned at the end of marking -> it should be ok to not follow the tricolor invariant" + self blackenObject: objOop. + ^false]. + + ((manager isEphemeronFormat: format) + and: [manager activeAndDeferredScan: objOop]) ifTrue: + [self blackenObject: objOop. + ^false]. + + "we know it is an object that can contain we have to follow" + self pushOnMarkingStackAndMakeGrey: objOop. + + ^ true! Item was added: + ----- Method: SpurIncrementalMarker>>markAndTrace: (in category 'marking - incremental') ----- + markAndTrace: objOop + + self halt.! Item was added: + ----- Method: SpurIncrementalMarker>>markAndTraceClassOf: (in category 'marking - incremental') ----- + markAndTraceClassOf: objOop + "Ensure the class of the argument is marked, pushing it on the markStack if not already marked. + And for one-way become, which can create duplicate entries in the class table, make sure + objOop's classIndex refers to the classObj's actual classIndex. + Note that this is recursive, but the metaclass chain should terminate quickly." + <inline: false> + | classIndex classObj realClassIndex | + classIndex := manager classIndexOf: objOop. + classObj := manager classOrNilAtIndex: classIndex. + + self assert: (coInterpreter objCouldBeClassObj: classObj). + realClassIndex := manager rawHashBitsOf: classObj. + + (classIndex ~= realClassIndex + and: [classIndex > manager lastClassIndexPun]) ifTrue: + [manager setClassIndexOf: objOop to: realClassIndex]. + "classObj = 16rAEC3C8 ifTrue: [self halt]." + (manager isWhite: classObj) ifTrue: + [ + "classes in young space do not get deleted + we do not want to color young space objects" + (manager isOldObject: classObj) + ifTrue: [self pushOnMarkingStackAndMakeGrey: classObj]. + self markAndTraceClassOf: classObj]! Item was added: + ----- Method: SpurIncrementalMarker>>markAndTraceObjStack:andContents: (in category 'marking-initialization') ----- + markAndTraceObjStack: stackOrNil andContents: markAndTraceContents + "An obj stack is a stack of objects stored in a hidden root slot, such + as the markStack or the ephemeronQueue. It is a linked list of + segments, with the hot end at the head of the list. It is a word object. + The stack pointer is in ObjStackTopx and 0 means empty." + <inline: false> + | index field | + stackOrNil = manager nilObj ifTrue: + [^self]. + manager setIsMarkedOf: stackOrNil to: true. + self assert: (manager numSlotsOfAny: stackOrNil) = ObjStackPageSlots. + field := manager fetchPointer: ObjStackNextx ofObject: stackOrNil. + field ~= 0 ifTrue: + [self markAndTraceObjStack: field andContents: markAndTraceContents]. + field := stackOrNil. + [field := manager fetchPointer: ObjStackFreex ofObject: field. + field ~= 0] whileTrue: + [manager setIsMarkedOf: field to: true]. + markAndTraceContents ifFalse: + [^self]. + "There are four fixed slots in an obj stack, and a Topx of 0 indicates empty, so + if there were 6 slots in an oop stack, full would be 2, and the last 0-rel index is 5." + index := (manager fetchPointer: ObjStackTopx ofObject: stackOrNil) + ObjStackNextx. + [index >= ObjStackFixedSlots] whileTrue: + [field := manager followObjField: index ofObject: stackOrNil. + (manager isImmediate: field) ifFalse: + [self pushOnMarkingStackAndMakeGrey: field]. + index := index - 1]! Item was added: + ----- Method: SpurIncrementalMarker>>markAndTraceWeaklingsFrom: (in category 'weaklings and ephemerons') ----- + markAndTraceWeaklingsFrom: startIndex + "Mark weaklings on the weaklingStack, ignoring startIndex + number of elements on the bottom of the stack. Answer + the size of the stack *before* the enumeration began." + ^manager objStack: manager weaklingStack from: startIndex do: + [:weakling| + self deny: (manager isForwarded: weakling). + self flag: #Todo. "this will probably just push a part on the marking stack. This will get resolved with the next mark loop" + self markAndTraceClassOf: weakling. + + "N.B. generateToByDoLimitExpression:negative:on: guards against (unsigned)0 - 1 going +ve" + 0 to: (manager numStrongSlotsOfWeakling: weakling) - 1 do: + [:i| | field | + field := manager followOopField: i ofObject: weakling. + ((manager isImmediate: field) or: [manager isMarked: field]) ifFalse: + [self incrementalMarkAndTrace: field]]]! Item was added: + ----- Method: SpurIncrementalMarker>>markFrom:nSlots:of: (in category 'as yet unclassified') ----- + markFrom: startIndex nSlots: anAmount of: objOop + + startIndex to: startIndex + anAmount - 1 + do: [:index | | slot | + slot := manager fetchPointer: index ofObject: objOop. + + (manager isNonImmediate: slot) + ifTrue: [ + (manager isForwarded: slot) + ifTrue: [slot := manager fixFollowedField: index ofObject: objOop withInitialValue: slot]. + self markAndShouldScan: slot]]! Item was added: + ----- Method: SpurIncrementalMarker>>markHelperStructures (in category 'marking-initialization') ----- + markHelperStructures + "marks the structures needed during GC" + + manager setIsMarkedOf: manager rememberedSetObj to: true. + manager setIsMarkedOf: manager freeListsObj to: true. + + (manager isWeakNonImm: manager classTableFirstPage) ifTrue: + [self pushOnMarkingStackAndMakeGrey: manager hiddenRootsObj]. + + manager setIsMarkedOf: manager hiddenRootsObj to: true! Item was added: + ----- Method: SpurIncrementalMarker>>markInactiveEphemerons (in category 'weaklings and ephemerons') ----- + markInactiveEphemerons + "Go through the unscanned ephemerons, marking the inactive ones, and + removing them from the unscanned ephemerons. Answer if any inactive + ones were found. We cannot fire the ephemerons until all are found to + be active since scan-marking an inactive ephemeron later in the set may + render a previously-observed active ephemeron as inactive." + | foundInactive ptr | + self break. + foundInactive := false. + ptr := manager unscannedEphemerons start. + [ptr < manager unscannedEphemerons top] whileTrue: + [| ephemeron key | + key := manager followedKeyOfEphemeron: (ephemeron := manager longAt: ptr). + ((manager isImmediate: key) or: [manager isMarked: key]) + ifTrue: + [foundInactive := true. + "Now remove the inactive ephemeron from the set, and scan-mark it. + Scan-marking it may add more ephemerons to the set." + manager unscannedEphemerons top: manager unscannedEphemerons top - manager bytesPerOop. + manager unscannedEphemerons top > ptr ifTrue: + [manager longAt: ptr put: (manager longAt: manager unscannedEphemerons top)]. + self markAndTrace: ephemeron] + ifFalse: + [ptr := ptr + manager bytesPerOop]]. + ^foundInactive! Item was added: + ----- Method: SpurIncrementalMarker>>markNSlots:of: (in category 'as yet unclassified') ----- + markNSlots: aNumber of: objOop + + self markFrom: 0 nSlots: aNumber of: objOop! Item was added: + ----- Method: SpurIncrementalMarker>>markWeaklingsAndMarkAndFireEphemerons (in category 'weaklings and ephemerons') ----- + markWeaklingsAndMarkAndFireEphemerons + "After the initial scan-mark is complete ephemerons can be processed. + Weaklings have accumulated on the weaklingStack, but more may be + uncovered during ephemeron processing. So trace the strong slots + of the weaklings, and as ephemerons are processed ensure any newly + reached weaklings are also traced." + | numTracedWeaklings | + <inline: false> + numTracedWeaklings := 0. + [coInterpreter markAndTraceUntracedReachableStackPages. + coInterpreter markAndTraceMachineCodeOfMarkedMethods. + "Make sure all reached weaklings have their strong slots traced before firing ephemerons..." + [numTracedWeaklings := self markAndTraceWeaklingsFrom: numTracedWeaklings. + (manager sizeOfObjStack: manager weaklingStack) > numTracedWeaklings] whileTrue. + manager noUnscannedEphemerons ifTrue: + [coInterpreter + markAndTraceUntracedReachableStackPages; + markAndTraceMachineCodeOfMarkedMethods; + freeUntracedStackPages; + freeUnmarkedMachineCode. + ^self]. + self markInactiveEphemerons ifFalse: + [manager fireAllUnscannedEphemerons]. + self markAllUnscannedEphemerons] + repeat! Item was added: + ----- Method: SpurIncrementalMarker>>markersMarkObjects: (in category 'as yet unclassified') ----- + markersMarkObjects: objectsShouldBeUnmarkedAndUnmarkedClassesShouldBeExpunged + + "mark objects has to mark all available objects in on go (e.g. used in allInstances where you only want live objects so you do not keep objects that should + be collected alive, as they get collected into an array that then holds a reference to the object) + In the incremental case we need to throw away our marking progress until now :( (in incremental collection garbage can stay around until the next round + of collection when we encountered an object during earlier stages of marking when an object is still alive, but it gets unreferenced during one of the + following mutator runs)" + + self flag: #Todo. "we made a (forced) complete marking. Lets use the results" + self completeMarkObjects. + self assert: (manager isEmptyObjStack: manager markStack).! Item was added: + ----- Method: SpurIncrementalMarker>>pushAllRootsOnMarkStack (in category 'root-scanning') ----- + pushAllRootsOnMarkStack + "Roots are: + 1. references from the stack + 2. references from the hidden roots + 3. references from extra roots? + 4. references from young space (it was recently scavenged -> only alive objects)" + + + self pushInternalStructuresOnMarkStack. + self pushStackReferencesOnMarkingStack. + self pushNewSpaceReferencesOnMarkingStack.! Item was added: + ----- Method: SpurIncrementalMarker>>pushExtraRootsReferencesOnMarkingStack (in category 'root-scanning') ----- + pushExtraRootsReferencesOnMarkingStack + + self assert: manager remapBufferCount = 0. + + 1 to: manager extraRootCount do: + [:i| | oop | + oop := (manager extraRoots at: i) at: 0. + ((manager isImmediate: oop) or: [manager isFreeObject: oop]) ifFalse: + [ + self flag: #Todo. "lets see how it goes " + self markAndShouldScan: oop]]! Item was added: + ----- Method: SpurIncrementalMarker>>pushHiddenRootsReferencesOnMarkingStack (in category 'root-scanning') ----- + pushHiddenRootsReferencesOnMarkingStack + + | classTablePageSizeLocal | + self markAndTraceObjStack: manager markStack andContents: false. + self markAndTraceObjStack: manager weaklingStack andContents: false. + self markAndTraceObjStack: manager mournQueue andContents: true. + self markAndTraceObjStack: manager ephemeronStack andContents: false. + + classTablePageSizeLocal := manager numStrongSlotsOfInephemeral: manager classTableFirstPage. + self markNSlots: classTablePageSizeLocal of: manager classTableFirstPage. + self blackenObject: manager classTableFirstPage. + + 1 to: manager numClassTablePages - 1 do: + [:i| manager setIsMarkedOf: (manager fetchPointer: i ofObject: manager hiddenRootsObj) + to: true].! Item was added: + ----- Method: SpurIncrementalMarker>>pushInternalStructuresOnMarkStack (in category 'root-scanning') ----- + pushInternalStructuresOnMarkStack + + self pushHiddenRootsReferencesOnMarkingStack. + self pushExtraRootsReferencesOnMarkingStack.! Item was added: + ----- Method: SpurIncrementalMarker>>pushNewSpaceReferencesOnMarkingStack (in category 'root-scanning') ----- + pushNewSpaceReferencesOnMarkingStack + + manager allNewSpaceObjectsDo: [:objOop | | format | + format := manager formatOf: objOop. + + self markAndTraceClassOf: objOop. + + "has the object pointers to visit?" + ((manager isNonImmediate: objOop) and: [(manager isPureBitsFormat: format) not]) + ifTrue: [ | slotNumber | + slotNumber := manager numStrongSlotsOfInephemeral: objOop. + + 0 to: slotNumber - 1 + do: [ :slotIndex | | slot | + slot := manager fetchPointer: slotIndex ofObject: objOop. + + (self shoudlBeOnMarkingStack: slot) + ifTrue: [self markAndShouldScan: slot]]]] + ! Item was added: + ----- Method: SpurIncrementalMarker>>pushOnMarkingStack: (in category 'marking-stack') ----- + pushOnMarkingStack: objOop + + manager push: objOop onObjStack: manager markStack! Item was added: + ----- Method: SpurIncrementalMarker>>pushOnMarkingStackAndMakeGrey: (in category 'marking-stack') ----- + pushOnMarkingStackAndMakeGrey: objOop + + manager push: objOop onObjStack: manager markStack. + manager setIsGreyOf: objOop to: true ! Item was added: + ----- Method: SpurIncrementalMarker>>pushOnMarkingStackAndMakeGreyIfNecessary: (in category 'marking-stack') ----- + pushOnMarkingStackAndMakeGreyIfNecessary: objOop + + ((manager isImmediate: objOop) and: [manager isWhite: objOop]) + ifTrue: [self pushOnMarkingStackAndMakeGrey: objOop]! Item was added: + ----- Method: SpurIncrementalMarker>>pushStackReferencesOnMarkingStack (in category 'root-scanning') ----- + pushStackReferencesOnMarkingStack + + coInterpreter incrementalMarkAndTraceInterpreterOops! Item was added: + ----- Method: SpurIncrementalMarker>>resetMarkProgress (in category 'marking - global') ----- + resetMarkProgress + + isCurrentlyMarking := false. + marking := false. + + manager emptyObjStack: manager markStack. + manager emptyObjStack: manager weaklingStack. + manager emptyObjStack: manager ephemeronStack! Item was added: + ----- Method: SpurIncrementalMarker>>resolveAllForwarders (in category 'marking - global') ----- + resolveAllForwarders + + self shouldBeImplemented! Item was added: + ----- Method: SpurIncrementalMarker>>shoudlBeOnMarkingStack: (in category 'marking-stack') ----- + shoudlBeOnMarkingStack: objOop + + <inline: true> + self flag: #Todo. "should be not immediate and no bit array" + ^ (manager isNonImmediate: objOop) and: [(manager isOldObject: objOop) and: [manager isWhite: objOop]]! Item was added: + ----- Method: SpurIncrementalMarker>>writeBarrierFor:at:with: (in category 'barrier') ----- + writeBarrierFor: anObject at: index with: value + "a dijkstra style write barrier with the addition of the generation check + objects that are not able to contain pointers are ignored too, as the write barries + should ensure we lose no references and this objects do not hold any of them" + <inline: true> + + self flag: #Todo. "we probably want the oldObject check to be the first one as it is only a pointer comparison and no dereferencing is needed" + + "((manager isImmediate: value) not and: [(manager isPureBitsNonImm: value)]) + ifTrue: [coInterpreter cr; print: 'saw: '; printHexnp: value; tab; flush]." + + (self marking and: [(manager isImmediate: value) not and: [(manager isOldObject: anObject) and: [(manager isOldObject: value) and: [manager isMarked: anObject]]]]) + ifTrue: [self markAndShouldScan: value]! Item was added: + SpurIncrementalMarker subclass: #SpurIncrementalMarkerSimulator + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'VMMaker-SpurGarbageCollectorSimulation'! Item was added: + ----- Method: SpurIncrementalMarkerSimulator>>blackenObject: (in category 'as yet unclassified') ----- + blackenObject: obj + + ^ GCEventLog + register: (GCBlackenEvent address: obj) + expecting: {[:evt | (evt isKindOf: GCUngreyEvent) and: [evt address = obj]]. + [:evt | (evt isKindOf: GCMarkEvent) and: [evt address = obj]]} + doing: [super blackenObject: obj]! Item was added: + ----- Method: SpurIncrementalMarkerSimulator>>finishMarking (in category 'as yet unclassified') ----- + finishMarking + + ^ GCEventLog + inContext: #finishMarking + do: [super finishMarking]! Item was added: + ----- Method: SpurIncrementalMarkerSimulator>>incrementalMark (in category 'marking - incremental') ----- + incrementalMark + + ^ GCEventLog + inContext: #IncrementalMark + do: [super incrementalMark]! Item was added: + ----- Method: SpurIncrementalMarkerSimulator>>incrementalMarkObjects (in category 'marking - incremental') ----- + incrementalMarkObjects + + ^ GCEventLog + inContext: #marking + do: [super incrementalMarkObjects]! Item was added: + ----- Method: SpurIncrementalMarkerSimulator>>initForNewMarkingPassIfNecessary (in category 'marking-initialization') ----- + initForNewMarkingPassIfNecessary + + ^ GCEventLog + inContext: #markingInit + do: [super initForNewMarkingPassIfNecessary]! Item was added: + ----- Method: SpurIncrementalMarkerSimulator>>pushAllRootsOnMarkStack (in category 'root-scanning') ----- + pushAllRootsOnMarkStack + + GCEventLog + inContext: #rootScanning + do: [super pushAllRootsOnMarkStack] ! Item was added: + ----- Method: SpurIncrementalMarkerSimulator>>pushExtraRootsReferencesOnMarkingStack (in category 'root-scanning') ----- + pushExtraRootsReferencesOnMarkingStack + + GCEventLog + inContext: #extraRootScanning + do: [super pushExtraRootsReferencesOnMarkingStack] ! Item was added: + ----- Method: SpurIncrementalMarkerSimulator>>pushHiddenRootsReferencesOnMarkingStack (in category 'root-scanning') ----- + pushHiddenRootsReferencesOnMarkingStack + + GCEventLog + inContext: #hiddenRootScanning + do: [super pushHiddenRootsReferencesOnMarkingStack] ! Item was added: + ----- Method: SpurIncrementalMarkerSimulator>>pushNewSpaceReferencesOnMarkingStack (in category 'root-scanning') ----- + pushNewSpaceReferencesOnMarkingStack + + GCEventLog + inContext: #newSpaceScanning + do: [super pushNewSpaceReferencesOnMarkingStack]! Item was added: + ----- Method: SpurIncrementalMarkerSimulator>>pushOnMarkingStackAndMakeGrey: (in category 'marking-stack') ----- + pushOnMarkingStackAndMakeGrey: obj + + super pushOnMarkingStackAndMakeGrey: obj + ! Item was added: + ----- Method: SpurIncrementalMarkerSimulator>>pushStackReferencesOnMarkingStack (in category 'root-scanning') ----- + pushStackReferencesOnMarkingStack + + GCEventLog + inContext: #stackScanning + do: [super pushStackReferencesOnMarkingStack]! Item was added: + ----- Method: SpurIncrementalMarkerSimulator>>writeBarrierFor:at:with: (in category 'barrier') ----- + writeBarrierFor: anObject at: index with: value + + GCEventLog + contextToKeepOnEvent: #writeBarrier + do: [super writeBarrierFor: anObject at: index with: value] + ! Item was added: + SpurCompactor subclass: #SpurIncrementalSweepAndCompact + instanceVariableNames: 'sweeper compactor' + classVariableNames: '' + poolDictionaries: '' + category: 'VMMaker-SpurGarbageCollector'! Item was added: + ----- Method: SpurIncrementalSweepAndCompact class>>declareCVarsIn: (in category 'nil') ----- + declareCVarsIn: aCCodeGenerator! Item was added: + ----- Method: SpurIncrementalSweepAndCompact class>>simulatorClass (in category 'as yet unclassified') ----- + simulatorClass + + "^ SpurIncrementalSweepAndCompactSimulator" + ^ self! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>assertNoSegmentBeingCompacted (in category 'as yet unclassified') ----- + assertNoSegmentBeingCompacted + <doNotGenerate> + + compactor assertNoSegmentBeingCompacted! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>biasForGC (in category 'api') ----- + biasForGC! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>biasForSnapshot (in category 'as yet unclassified') ----- + biasForSnapshot! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>compact (in category 'api - global') ----- + compact + + <doNotGenerate> + compactor completeCompact! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>compactor (in category 'as yet unclassified') ----- + compactor + + <doNotGenerate> + ^ compactor! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>currentSweepingEntity (in category 'as yet unclassified') ----- + currentSweepingEntity + + <doNotGenerate> + ^ sweeper currentSweepingEntity! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>freePastSegmentsAndSetSegmentToFill (in category 'api - incremental') ----- + freePastSegmentsAndSetSegmentToFill + + <doNotGenerate> + compactor freePastSegmentsAndSetSegmentToFill! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>incrementalCompact (in category 'api - incremental') ----- + incrementalCompact + + <doNotGenerate> + ^ compactor incrementalCompact! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>incrementalSweep (in category 'api - incremental') ----- + incrementalSweep + + <doNotGenerate> + ^ sweeper incrementalSweep! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>initialize (in category 'initialize-release') ----- + initialize + + sweeper := SpurIncrementalSweeper simulatorClass new. + compactor := SpurIncrementalCompactor simulatorClass new! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>isMobile: (in category 'as yet unclassified') ----- + isMobile: obj + + <inline: true> + self flag: #Todo. "investigate this one here" + ^ (manager isPinned: obj) not! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>manager: (in category 'as yet unclassified') ----- + manager: manager + + <doNotGenerate> + super manager: manager. + sweeper manager: manager. + compactor manager: manager! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>remapObj: (in category 'api') ----- + remapObj: objOop + "Scavenge or simply follow objOop. Answer the new location of objOop. + The send should have been guarded by a send of shouldRemapOop:. + The method is called remapObj: for compatibility with ObjectMemory." + <api> + <inline: false> + ^manager slidingCompactionRemapObj: objOop! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>resetComponents (in category 'api - global') ----- + resetComponents + + sweeper resetSweeper. + compactor resetCompactor! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>segmentToFill (in category 'as yet unclassified') ----- + segmentToFill + + <doNotGenerate> + ^ compactor segmentToFill! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>setInitialSweepingEntity (in category 'as yet unclassified') ----- + setInitialSweepingEntity + + sweeper currentSweepingEntity: manager firstObject! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>shouldRemapObj: (in category 'api') ----- + shouldRemapObj: objOop + "Answer if the obj should be scavenged, or simply followed. Sent via the compactor + from shouldRemapObj:. We test for being already scavenged because mapStackPages + via mapInterpreterOops may be applied twice in the context of a global GC where a + scavenge, followed by a scan-mark-free, and final compaction passes may result in + scavenged fields being visited twice." + <api> + <inline: false> + ^manager slidingCompactionShouldRemapObj: objOop! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>sweep (in category 'api - global') ----- + sweep + + <inline: true> + sweeper globalSweep! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>sweepAndCompact (in category 'api - global') ----- + sweepAndCompact + + self + sweep; + compact! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>sweeper (in category 'as yet unclassified') ----- + sweeper + + ^ sweeper! Item was added: + SpurIncrementalSweepAndCompact subclass: #SpurIncrementalSweepAndCompactSimulator + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'VMMaker-SpurGarbageCollectorSimulation'! Item was added: + ----- Method: SpurIncrementalSweepAndCompactSimulator>>incrementalCompact (in category 'api - incremental') ----- + incrementalCompact + + ^ GCEventLog + inContext: #compact + do: [super incrementalCompact] + ! Item was added: + ----- Method: SpurIncrementalSweepAndCompactSimulator>>incrementalSweep (in category 'api - incremental') ----- + incrementalSweep + + ^ GCEventLog + inContext: #sweep + do: [super incrementalSweep] + ! Item was added: + SpurCompactor subclass: #SpurIncrementalSweeper + instanceVariableNames: 'currentSweepingEntity isCurrentlySweeping currentSegmentUsed currentSegmentUnused currentSegmentsIndex currentsCycleSeenObjectCount currentSegmentsBridge' + classVariableNames: 'MaxObjectsToFree' + poolDictionaries: '' + category: 'VMMaker-SpurGarbageCollector'! Item was added: + ----- Method: SpurIncrementalSweeper class>>declareCVarsIn: (in category 'as yet unclassified') ----- + declareCVarsIn: aCCodeGenerator! Item was added: + ----- Method: SpurIncrementalSweeper class>>initialize (in category 'as yet unclassified') ----- + initialize + + MaxObjectsToFree := 10000! Item was added: + ----- Method: SpurIncrementalSweeper class>>simulatorClass (in category 'as yet unclassified') ----- + simulatorClass + + "^ SpurIncrementalSweeperSimulator" + ^ self! Item was added: + ----- Method: SpurIncrementalSweeper>>advanceSegment (in category 'as yet unclassified') ----- + advanceSegment + + self setOccupationAtIndex: currentSegmentsIndex used: currentSegmentUsed unused: currentSegmentUnused. + + currentSegmentUsed := currentSegmentUnused := 0. + currentSegmentsIndex := currentSegmentsIndex + 1. + + currentSegmentsIndex < manager segmentManager numSegments + ifTrue: [currentSegmentsBridge := manager segmentManager bridgeAt: currentSegmentsIndex] + ! Item was added: + ----- Method: SpurIncrementalSweeper>>bulkFreeChunkFrom: (in category 'api - global') ----- + bulkFreeChunkFrom: objOop + "The old space entity before objOop is necessarily a marked object. Attempts to free as many bytes + from objOop start as possible, looking ahead to free contiguous freechunks / unmarked objects" + | bytes start next currentObj | + self assert: (self canUseAsFreeSpace: objOop). + + start := manager startOfObject: objOop. + currentObj := objOop. + bytes := 0. + + [bytes := bytes + (manager bytesInBody: currentObj). + (manager isRemembered: currentObj) + ifTrue: + [self assert: (manager isFreeObject: currentObj) not. + scavenger forgetObject: currentObj]. + + next := manager objectStartingAt: start + bytes. + self assert: ((manager oop: next isLessThan: manager endOfMemory) + or: [next = manager endOfMemory and: [(self canUseAsFreeSpace: next) not]]). + + "we found the end of a segment (old space segments always end in a bridge). Advance to the next" + next = currentSegmentsBridge + ifTrue: [self advanceSegment]. + + (self canUseAsFreeSpace: next)] + whileTrue: [currentObj := next]. + + currentSegmentUnused := currentSegmentUnused + bytes. + ^ manager addFreeChunkWithBytes: bytes at: start! Item was added: + ----- Method: SpurIncrementalSweeper>>canUseAsFreeSpace: (in category 'testing') ----- + canUseAsFreeSpace: objOop + <inline: true> + ^ (manager isFreeObject: objOop) or: [(manager isMarked: objOop) not]! Item was added: + ----- Method: SpurIncrementalSweeper>>cautiousBulkFreeChunkFrom: (in category 'api - incremental') ----- + cautiousBulkFreeChunkFrom: objOop + "The old space entity before objOop is necessarily a marked object. Attempts to free as many bytes + from objOop start as possible, looking ahead to free contiguous freechunks / unmarked objects" + | bytes start next currentObj | + self assert: (self canUseAsFreeSpace: objOop). + + start := manager startOfObject: objOop. + currentObj := objOop. + bytes := 0. + + [bytes := bytes + (manager bytesInBody: currentObj). + (manager isRemembered: currentObj) + ifTrue: + [self assert: (manager isFreeObject: currentObj) not. + scavenger forgetObject: currentObj]. + + (manager isFreeObject: currentObj) + ifTrue: [ "we need to unlink chunks for concurrent sweeping. In the stop the world sweeper we can just reset the freeLists but here we need to keep them + around so the mutator can still work between sweeping passes" + + self flag: #Todo. "we want to optimize for lilliputian chunks!! For now it is ok(ish) but we have to do something about it. + At the moment I see 3 possibilities: + - have the lilliputian list always sorted (O(n) insert in the worst case!!) + - sort the lilliputian part before sweeping (O(n log n) at the start. but everytime before sweeping) + - be cheeky and discard the lilliputian list (problem: the mutator has no access to the list + it can insert unsorted chunks (for the duration of sweeping we could let it use a second list and just append it after sweeping)" + manager detachFreeObject: currentObj. + "self assert: manager totalFreeOldSpace = manager totalFreeListBytes." + currentSegmentUnused := currentSegmentUnused + (manager bytesInBody: currentSweepingEntity)]. + + next := manager objectStartingAt: start + bytes. + currentsCycleSeenObjectCount := currentsCycleSeenObjectCount + 1. + self assert: ((manager oop: next isLessThan: manager endOfMemory) + or: [next = manager endOfMemory and: [(self canUseAsFreeSpace: next) not]]). + + "we found the end of a segment (old space segments always end in a bridge). Advance to the next" + next = currentSegmentsBridge + ifTrue: [self advanceSegment]. + + (self canUseAsFreeSpace: next) and: [currentsCycleSeenObjectCount < MaxObjectsToFree]] + whileTrue: [currentObj := next]. + + ^ manager addFreeChunkWithBytes: bytes at: start! Item was added: + ----- Method: SpurIncrementalSweeper>>compact (in category 'api') ----- + compact + + <doNotGenerate> + ^ self shouldNotImplement + + ! Item was added: + ----- Method: SpurIncrementalSweeper>>compactorsSegmentToFill (in category 'as yet unclassified') ----- + compactorsSegmentToFill + + "this is incredible^10 ugly but I see no much better way to access the info" + + ^ manager gc compactor compactor segmentToFill! Item was added: + ----- Method: SpurIncrementalSweeper>>completeSweepCurrentSweepingEntity (in category 'api - incremental') ----- + completeSweepCurrentSweepingEntity + + (self canUseAsFreeSpace: currentSweepingEntity) + ifTrue: [currentSweepingEntity := self bulkFreeChunkFrom: currentSweepingEntity] + ifFalse: [self unmarkAndUpdateStats]. + ! Item was added: + ----- Method: SpurIncrementalSweeper>>currentSweepingEntity (in category 'accessing') ----- + currentSweepingEntity + + <cmacro: '() GIV(currentSweepingEntity)'> + ^ currentSweepingEntity! Item was added: + ----- Method: SpurIncrementalSweeper>>currentSweepingEntity: (in category 'accessing') ----- + currentSweepingEntity: anObject + + currentSweepingEntity := anObject.! Item was added: + ----- Method: SpurIncrementalSweeper>>doGlobalSweep (in category 'api - global') ----- + doGlobalSweep + "Iterate over all entities, in order, making large free chunks from free chunks and unmarked objects, + unmarking live objects and rebuilding the free lists." + + self initIfNecessary. + + [self oop: currentSweepingEntity isLessThan: manager endOfMemory] whileTrue: + [currentSweepingEntity = currentSegmentsBridge + ifTrue: [self advanceSegment] + ifFalse: [self completeSweepCurrentSweepingEntity]. + + currentSweepingEntity := self nextSweepingEntity]. + + manager checkFreeSpace: GCModeFull. + + "not sure if I need this (probably not), but it was in the original implementation" + manager unmarkSurvivingObjectsForCompact.! Item was added: + ----- Method: SpurIncrementalSweeper>>doIncrementalSweeping (in category 'api - incremental') ----- + doIncrementalSweeping + + "Scan the heap for unmarked objects and free them. Coalescence " + self assert: currentSweepingEntity notNil. + + currentsCycleSeenObjectCount := 0. + + [self oop: currentSweepingEntity isLessThan: manager endOfMemory] whileTrue: + [ currentSweepingEntity = currentSegmentsBridge + ifTrue: [self advanceSegment] + ifFalse: [self sweepCurrentSweepingEntity]. + + currentSweepingEntity := self nextSweepingEntity. + + currentsCycleSeenObjectCount >= MaxObjectsToFree + ifTrue: [^ false]]. + + manager checkFreeSpace: GCModeIncremental. + ^ true! Item was added: + ----- Method: SpurIncrementalSweeper>>finishSweeping (in category 'as yet unclassified') ----- + finishSweeping + + self resetSweeper. + manager updateSweepEndUsecs! Item was added: + ----- Method: SpurIncrementalSweeper>>globalSweep (in category 'api - global') ----- + globalSweep + <inline: #never> "for profiling" + + "throw away all free list info. As this appears to the mutator as an atomic operation it does not need it and we can rebuild it from scratch" + self resetFreeLists. + self doGlobalSweep. + self finishSweeping! Item was added: + ----- Method: SpurIncrementalSweeper>>incrementalSweep (in category 'api - incremental') ----- + incrementalSweep + <inline: #never> "for profiling" + + self initIfNecessary. + + self assert: manager validObjectColors. + + self doIncrementalSweeping + ifTrue: [self finishSweeping. + ^ true]. + + ^ false + ! Item was added: + ----- Method: SpurIncrementalSweeper>>initIfNecessary (in category 'api - incremental') ----- + initIfNecessary + + isCurrentlySweeping + ifFalse: [currentSegmentUsed := currentSegmentUnused := 0. + currentSegmentsIndex := 0. + currentSegmentsBridge := manager segmentManager bridgeAt: currentSegmentsIndex. + + currentSweepingEntity := manager firstObject. + + isCurrentlySweeping := true] + ! Item was added: + ----- Method: SpurIncrementalSweeper>>initialize (in category 'initialize-release') ----- + initialize + + super initialize. + isCurrentlySweeping := false! Item was added: + ----- Method: SpurIncrementalSweeper>>nextSweepingEntity (in category 'as yet unclassified') ----- + nextSweepingEntity + + | nextEntity reservedSegmentsFreeChunk | + nextEntity := manager objectAfter: currentSweepingEntity limit: manager endOfMemory. + reservedSegmentsFreeChunk := self compactorsSegmentToFill ifNotNil: [manager objectStartingAt: self compactorsSegmentToFill segStart]. + + nextEntity = reservedSegmentsFreeChunk + ifTrue: [ + currentSegmentUnused := manager bytesInBody: reservedSegmentsFreeChunk. + nextEntity := manager objectAfter: nextEntity limit: manager endOfMemory]. + + ^ nextEntity! Item was added: + ----- Method: SpurIncrementalSweeper>>resetFreeLists (in category 'api - global') ----- + resetFreeLists + manager resetFreeListHeads. + manager totalFreeOldSpace: 0.! Item was added: + ----- Method: SpurIncrementalSweeper>>resetSweeper (in category 'as yet unclassified') ----- + resetSweeper + + "reset all incremental progress. To be used before doing a global sweep to leave the sweeper in the correct state for the next time" + isCurrentlySweeping := false. + currentSweepingEntity := 0. + currentSegmentUsed := nil. + currentSegmentUnused := nil. + currentSegmentsIndex := nil. + currentsCycleSeenObjectCount := 0 + + ! Item was added: + ----- Method: SpurIncrementalSweeper>>setOccupationAtIndex:used:unused: (in category 'compactor support') ----- + setOccupationAtIndex: segmentIndex used: used unused: unused + "WARNING: Resets the isCompacted bit" + "Swizzle is abused bit 16 isBeingCompacted bits 0-15 occupation + Setting occupation resets the claim bit" + | occupation segInfo | + <var: 'segInfo' type: #'SpurSegmentInfo *'> + segInfo := self addressOf: (manager segmentManager segments at: segmentIndex). + "careful with overflow here..." + occupation := ((used asFloat / (used + unused)) * 16rFFFF) asInteger. + self assert: (occupation between: 0 and: 16rFFFF). + segInfo swizzle: occupation! Item was added: + ----- Method: SpurIncrementalSweeper>>sweepCurrentSweepingEntity (in category 'api - incremental') ----- + sweepCurrentSweepingEntity + + (self canUseAsFreeSpace: currentSweepingEntity) + ifTrue: [currentSweepingEntity := self cautiousBulkFreeChunkFrom: currentSweepingEntity] + ifFalse: [self unmarkAndUpdateStats]. + ! Item was added: + ----- Method: SpurIncrementalSweeper>>unmark: (in category 'api') ----- + unmark: objOop + + self assert: ((manager isMarked: objOop) and: [(manager isFreeObject: objOop) not]). + (manager isSegmentBridge: objOop) ifFalse: [ + manager + setIsMarkedOf: objOop to: false; + setIsGreyOf: objOop to: false]. + (manager isPinned: objOop) ifTrue: [manager segmentManager notePinned: objOop]! Item was added: + ----- Method: SpurIncrementalSweeper>>unmarkAndUpdateStats (in category 'api - incremental') ----- + unmarkAndUpdateStats + + self unmark: currentSweepingEntity. + + currentSegmentUsed := currentSegmentUsed + (manager bytesInBody: currentSweepingEntity). + currentsCycleSeenObjectCount := currentsCycleSeenObjectCount + 1 + ! Item was added: + SpurIncrementalSweeper subclass: #SpurIncrementalSweeperSimulator + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'VMMaker-SpurGarbageCollectorSimulation'! Item was added: + ----- Method: SpurIncrementalSweeperSimulator>>canUseAsFreeSpace: (in category 'as yet unclassified') ----- + canUseAsFreeSpace: objOop + + "objOop = 16r25FDBD8 ifTrue: [self halt]." + ^ super canUseAsFreeSpace: objOop! Item was added: + ----- Method: SpurIncrementalSweeperSimulator>>doIncrementalSweeping (in category 'api - incremental') ----- + doIncrementalSweeping + + ^ GCEventLog + inContext: #doIncrementalSweep + do: [super doIncrementalSweeping]! Item was added: + ----- Method: SpurIncrementalSweeperSimulator>>finishSweeping (in category 'as yet unclassified') ----- + finishSweeping + + ^ GCEventLog + inContext: #finishSweeping + do: [super finishSweeping]! Item was added: + ----- Method: SpurIncrementalSweeperSimulator>>incrementalSweep (in category 'api - incremental') ----- + incrementalSweep + + ^ GCEventLog + inContext: #incrementalSweep + do: [super incrementalSweep]! Item was added: + ----- Method: SpurIncrementalSweeperSimulator>>initIfNecessary (in category 'api - incremental') ----- + initIfNecessary + + ^ GCEventLog + inContext: #sweepInit + do: [super initIfNecessary]! Item was added: + ----- Method: SpurIncrementalSweeperSimulator>>unmark: (in category 'api') ----- + unmark: objOop + + super unmark: objOop + "^ GCEventLog + register: (GCWhitenEvent address: objOop) + expecting: { + [:evt | evt = (GCUnmarkEvent address: objOop)]. + [:evt | evt = (GCUngreyEvent address: objOop)]} + doing: [super unmark: objOop]"! Item was added: + CogClass subclass: #SpurMarker + instanceVariableNames: 'manager coInterpreter marking' + classVariableNames: '' + poolDictionaries: 'SpurObjStackConstants VMBasicConstants' + category: 'VMMaker-SpurGarbageCollector'! Item was added: + ----- Method: SpurMarker class>>declareCVarsIn: (in category 'translation') ----- + declareCVarsIn: aCCodeGenerator + "resolve keys present in both the incremental marker and the all at once mark when incremental GC is selected for generation" + + SpurMemoryManager wantsIncrementalGC ifFalse: [^ self]. + + self selectorsInAllAtOnceMarkerAndIncrementalMarker + do: [:key | + aCCodeGenerator + staticallyResolveMethodNamed: key + forClass: self + to: (self staticallyResolvePolymorphicSelector: key)] + ! Item was added: + ----- Method: SpurMarker class>>hasPolymorphicSelectors (in category 'translation') ----- + hasPolymorphicSelectors + "when using the incremental gc we have polymorphic selectors and have to resolve them" + + ^ SpurMemoryManager wantsIncrementalGC! Item was added: + ----- Method: SpurMarker class>>selectorsInAllAtOnceMarkerAndIncrementalMarker (in category 'as yet unclassified') ----- + selectorsInAllAtOnceMarkerAndIncrementalMarker + + | subclasses otherMarker | + subclasses := SpurMarker allSubclasses + select: [:ea | (ea name endsWith: 'Simulator') not]. "ignore simulators as they never get generated" + self assert: subclasses size = 2. "code written with SpurAllAtOnceMarker and SpurIncrementalMarker in mind. If you extend the class hierarchy you potentially have to change this method too" + + otherMarker := subclasses detect: [:class | class ~= self]. + + ^ (self selectors intersection: otherMarker selectors)! Item was added: + ----- Method: SpurMarker class>>staticallyResolvePolymorphicSelector: (in category 'nil') ----- + staticallyResolvePolymorphicSelector: aSelectorSymbol + + ^ (self selectorsInAllAtOnceMarkerAndIncrementalMarker includes: aSelectorSymbol) + ifTrue: [super staticallyResolvePolymorphicSelector: aSelectorSymbol] + ifFalse: [aSelectorSymbol]! Item was added: + ----- Method: SpurMarker>>coInterpreter: (in category 'accessing') ----- + coInterpreter: aVMSimulator + <doNotGenerate> + + coInterpreter := aVMSimulator! Item was added: + ----- Method: SpurMarker>>initialize (in category 'initialize-release') ----- + initialize + + marking := false! Item was added: + ----- Method: SpurMarker>>manager: (in category 'accessing') ----- + manager: aSpurNBitMMXEndianSimulator + <doNotGenerate> + manager := aSpurNBitMMXEndianSimulator. + + aSpurNBitMMXEndianSimulator coInterpreter ifNotNil: + [:coint | coInterpreter := coint].! Item was added: + ----- Method: SpurMarker>>markAndTrace: (in category 'marking') ----- + markAndTrace: objOop + + ^ self subclassResponsibility! Item was added: + ----- Method: SpurMarker>>markersMarkObjects: (in category 'as yet unclassified') ----- + markersMarkObjects: objectsShouldBeUnmarkedAndUnmarkedClassesShouldBeExpunged + + self shouldBeImplemented! Item was added: + ----- Method: SpurMarker>>marking (in category 'marking') ----- + marking + <cmacro: '() GIV(marking)'> + + ^ marking! Item was added: + ----- Method: SpurMarker>>writeBarrierFor:at:with: (in category 'barrier') ----- + writeBarrierFor: anObject at: index with: value! Item was changed: CogClass subclass: #SpurMemoryManager (excessive size, no diff calculated) Item was changed: ----- Method: SpurMemoryManager class>>ancilliaryClasses (in category 'translation') ----- ancilliaryClasses "Answer any extra classes to be included in the translation." + ^{ SpurScavengeLogRecord. SpurSegmentManager. SpurSegmentInfo }, + self gcClass classesForTranslation, - ^{ SpurGenerationScavenger. SpurScavengeLogRecord. SpurSegmentManager. SpurSegmentInfo }, - self compactorClass classesForTranslation, SpurNewSpaceSpace withAllSubclasses ! Item was changed: ----- Method: SpurMemoryManager class>>compactorClass (in category 'accessing class hierarchy') ----- compactorClass "Answer the compaction algorithm to use." + ^Smalltalk classNamed: (InitializationOptions at: #compactorClass ifAbsent: [self gcClass compactorClass name])! - ^Smalltalk classNamed: (InitializationOptions at: #compactorClass ifAbsent: [#SpurPlanningCompactor])! Item was changed: ----- Method: SpurMemoryManager class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator self class == thisContext methodClass ifFalse: [^self]. "Don't duplicate decls in subclasses" aCCodeGenerator removeVariable: 'memory'. "memory is a simulation time thing only" self declareCAsOop: #( freeStart scavengeThreshold newSpaceStart pastSpaceStart oldSpaceStart lowSpaceThreshold freeOldSpaceStart endOfMemory) in: aCCodeGenerator. self declareCAsUSqLong: (self allInstVarNames select: [:ivn| ivn endsWith: 'Usecs']), #(statAllocatedBytes) in: aCCodeGenerator. aCCodeGenerator var: #lastHash type: #usqInt; var: #freeListsMask type: #usqInt; var: #freeLists type: #'sqInt *'; var: #objStackInvalidBecause type: #'char *'; var: #unscannedEphemerons type: #SpurContiguousObjStack; var: #heapGrowthToSizeGCRatio type: #float; var: #heapSizeAtPreviousGC type: #usqInt; var: #totalFreeOldSpace type: #usqInt; var: #maxOldSpaceSize type: #usqInt. aCCodeGenerator var: #oldSpaceUsePriorToScavenge type: #sqLong. aCCodeGenerator var: #remapBuffer declareC: 'sqInt remapBuffer[RemapBufferSize + 1 /* ', (RemapBufferSize + 1) printString, ' */]'. aCCodeGenerator var: #extraRoots + declareC: 'sqInt *extraRoots[ExtraRootsSize + 1 /* ', (ExtraRootsSize + 1) printString, ' */]'. + + self wantsIncrementalGC + ifTrue: [aCCodeGenerator + staticallyResolvedPolymorphicReceiver: 'marker' to: SpurIncrementalMarker; + "hack!! see SpurMemoryManager>>staticallyResolvePolymorphicSelector: why we use this" + staticallyResolvedPolymorphicReceiver: 'objectMemory' to: SpurMemoryManager]! - declareC: 'sqInt *extraRoots[ExtraRootsSize + 1 /* ', (ExtraRootsSize + 1) printString, ' */]'! Item was added: + ----- Method: SpurMemoryManager class>>gcClass (in category 'accessing class hierarchy') ----- + gcClass + "Answer the garbage collection algorithm to use." + ^Smalltalk classNamed: (InitializationOptions at: #gcClass ifAbsent: [#SpurIncrementalGarbageCollector])! Item was changed: ----- Method: SpurMemoryManager class>>initialize (in category 'class initialization') ----- initialize "SpurMemoryManager initialize" BitsPerByte := 8. "Initialize at least the become constants for the Spur bootstrap where the old ObjectMemory simulator is used before a Spur simulator is created.." self initializeSpurObjectRepresentationConstants. "An obj stack is a stack of objects stored in a hidden root slot, such as the markStack or the ephemeronQueue. It is a linked list of segments, with the hot end at the head of the list. It is a word object. The stack pointer is in ObjStackTopx and 0 means empty. The list goes through ObjStackNextx. We don't want to shrink objStacks, since they're used in GC and it's good to keep their memory around. So unused pages created by popping emptied pages are kept on the ObjStackFreex list. ObjStackNextx must be the last field for swizzleObjStackAt:." ObjStackPageSlots := 4092. "+ double header = 16k bytes per page in 32-bits, 32k bytes per page in 64 bits" ObjStackTopx := 0. ObjStackMyx := 1. ObjStackFreex := 2. ObjStackNextx := 3. ObjStackFixedSlots := 4. ObjStackLimit := ObjStackPageSlots - ObjStackFixedSlots. "The hiddenRootsObject contains the classTable pages and up to 8 additional objects. Currently we use four; the three objStacks (the mark stack, the weaklings and the mourn queue), and the rememberedSet." MarkStackRootIndex := self basicNew classTableRootSlots. WeaklingStackRootIndex := MarkStackRootIndex + 1. MournQueueRootIndex := MarkStackRootIndex + 2. RememberedSetRootIndex := MarkStackRootIndex + 3. + EphemeronStackRootIndex := MarkStackRootIndex + 4. MarkObjectsForEnumerationPrimitives := false. "The remap buffer support is for compatibility; Spur doesn't GC during allocation. Eventually this should die." RemapBufferSize := 25. "Extra roots are for plugin support." ExtraRootsSize := 64. "max. # of external roots; used e.g. by the PyBridge plugin which uses three entries" "gcPhaseInProgress takes these values to identify phases as required." ScavengeInProgress := 1. SlidingCompactionInProgress := 2! Item was changed: ----- Method: SpurMemoryManager class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') ----- isNonArgumentImplicitReceiverVariableName: aString + ^#('self' 'coInterpreter' 'manager' 'scavenger' 'segmentManager' 'compactor' 'planningCompactor' 'selectiveCompactor' 'heapMap' 'marker' 'sweeper' 'gc' 'allAtOnceMarker') includes: aString! - ^#('self' 'coInterpreter' 'manager' 'scavenger' 'segmentManager' 'compactor' 'planningCompactor' 'selectiveCompactor' 'heapMap') includes: aString! Item was added: + ----- Method: SpurMemoryManager class>>markerClass (in category 'accessing class hierarchy') ----- + markerClass + "Answer the marking algorithm to use." + ^Smalltalk classNamed: (InitializationOptions at: #markerClass ifAbsent: [self gcClass markerClass name])! Item was added: + ----- Method: SpurMemoryManager class>>staticallyResolvePolymorphicSelector: (in category 'as yet unclassified') ----- + staticallyResolvePolymorphicSelector: aSelectorSymbol + + "resolve markAndTrace: to the allAtOnce one, as we avoided using markAndTrace: for incremental marking we + can (and have to) always resolve this to SpurAllAtOnceMarker>>markAndTrace:" + + ^ self wantsIncrementalGC + ifTrue: [aSelectorSymbol = #markAndTrace: + ifTrue: [SpurAllAtOnceMarker staticallyResolvePolymorphicSelector: aSelectorSymbol] + ifFalse: [aSelectorSymbol]] + ifFalse: [aSelectorSymbol]! Item was added: + ----- Method: SpurMemoryManager class>>wantsIncrementalGC (in category 'as yet unclassified') ----- + wantsIncrementalGC + + ^ self gcClass = SpurIncrementalGarbageCollector! Item was changed: ----- Method: SpurMemoryManager>>addFreeChunkWithBytes:at: (in category 'free space') ----- addFreeChunkWithBytes: bytes at: address + + <var: 'bytes' type: #'usqInt'> totalFreeOldSpace := totalFreeOldSpace + bytes. ^self freeChunkWithBytes: bytes at: address! Item was changed: ----- Method: SpurMemoryManager>>addToFreeList:bytes: (in category 'free space') ----- addToFreeList: freeChunk bytes: chunkBytes "Add freeChunk to the relevant freeList. For the benefit of sortedFreeObject:, if freeChunk is large, answer the treeNode it is added to, if it is added to the next list of a freeTreeNode, otherwise answer 0." | index | + <var: 'chunkBytes' type: #'usqInt'> "coInterpreter transcript ensureCr. coInterpreter print: 'freeing '. self printFreeChunk: freeChunk." self assert: (self isFreeObject: freeChunk). self assert: chunkBytes = (self bytesInBody: freeChunk). "Too slow to be enabled byt default but useful to debug Selective... self deny: (compactor isSegmentBeingCompacted: (segmentManager segmentContainingObj: freeChunk))." index := chunkBytes / self allocationUnit. index < self numFreeLists ifTrue: [self setNextFreeChunkOf: freeChunk withValue: (freeLists at: index) chunkBytes: chunkBytes. (self isLilliputianSize: chunkBytes) ifFalse: [self storePointer: self freeChunkPrevIndex ofFreeChunk: freeChunk withValue: 0]. freeLists at: index put: freeChunk. freeListsMask := freeListsMask bitOr: 1 << index. ^0]. ^self addToFreeTree: freeChunk bytes: chunkBytes! Item was changed: ----- Method: SpurMemoryManager>>allInstancesOf: (in category 'primitive support') ----- allInstancesOf: aClass "Attempt to answer an array of all objects, excluding those that may be garbage collected as a side effect of allocating the result array. If no memory is available answer the number of instances as a SmallInteger. Since objects are at least 16 bytes big, and the largest SmallInteger covers 1/4 of the address space, the count can never overflow." | classIndex freeChunk ptr start limit count bytes | classIndex := self rawHashBitsOf: aClass. classIndex = 0 ifTrue: [freeChunk := self allocateSlots: 0 format: self arrayFormat classIndex: ClassArrayCompactIndex. ^freeChunk]. + gc markObjectsForEnumerationPrimitives ifTrue: + [gc finishGCPass. + gc markObjectsCompletely]. "may not want to revive objects unnecessarily; but marking is sloooow." - MarkObjectsForEnumerationPrimitives ifTrue: - [self markObjects: true]. "may not want to revive objects unnecessarily; but marking is sloooow." freeChunk := self allocateLargestFreeChunk. "N.B. Does /not/ update totalFreeOldSpace" start := freeChunk + self baseHeaderSize. limit := self addressAfter: freeChunk. (self isClassAtUniqueIndex: aClass) ifTrue: [self uniqueIndex: classIndex allInstancesInto: start limit: limit resultsInto: [:c :p| count := c. ptr := p]] ifFalse: [self ambiguousClass: aClass allInstancesInto: start limit: limit resultsInto: [:c :p| count := c. ptr := p]]. self assert: (self isEmptyObjStack: markStack). + gc markObjectsForEnumerationPrimitives - MarkObjectsForEnumerationPrimitives ifTrue: [self assert: self allObjectsUnmarked. self emptyObjStack: weaklingStack] ifFalse: [self assert: (self isEmptyObjStack: weaklingStack)]. (count > (ptr - start / self bytesPerOop) "not enough room" or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word" [self freeObject: freeChunk. ^self integerObjectOf: count]. count < self numSlotsMask ifTrue: [| smallObj | smallObj := self allocateSlots: count format: self arrayFormat classIndex: ClassArrayCompactIndex. 0 to: count - 1 do: [:i| self storePointerUnchecked: i ofObject: smallObj withValue: (self fetchPointer: i ofFreeChunk: freeChunk)]. self freeChunkWithBytes: (self bytesInBody: freeChunk) at: (self startOfObject: freeChunk). self beRootIfOld: smallObj. self checkFreeSpace: GCModeFull. ^smallObj]. bytes := self largeObjectBytesForSlots: count. start := self startOfObject: freeChunk. self freeChunkWithBytes: limit - start - bytes at: start + bytes. totalFreeOldSpace := totalFreeOldSpace - bytes. self rawOverflowSlotsOf: freeChunk put: count. self set: freeChunk classIndexTo: ClassArrayCompactIndex formatTo: self arrayFormat. + gc maybeModifyGCFlagsOf: freeChunk. self possibleRootStoreInto: freeChunk. self checkFreeSpace: GCModeFull. + self runLeakCheckerFor: GCModeFull excludeUnmarkedObjs: true classIndicesShouldBeValid: true. + coInterpreter cr; print: 'allinstances in: '; printHex: freeChunk; tab; flush. - self runLeakCheckerFor: GCModeFull. ^freeChunk! Item was changed: ----- Method: SpurMemoryManager>>allObjects (in category 'primitive support') ----- allObjects "Attempt to answer an array of all objects, excluding those that may be garbage collected as a side effect of allocating the result array. If no memory is available answer the number of objects as a SmallInteger. Since objects are at least 16 bytes big, and the largest SmallInteger covers 1/4 of the address space, the count can never overflow." | freeChunk ptr start limit count bytes | + gc markObjectsForEnumerationPrimitives ifTrue: + [gc markObjects: true]. "may not want to revive objects unnecessarily; but marking is sloooow." - MarkObjectsForEnumerationPrimitives ifTrue: - [self markObjects: true]. "may not want to revive objects unnecessarily; but marking is sloooow." freeChunk := self allocateLargestFreeChunk. "N.B. Does /not/ update totalFreeOldSpace" ptr := start := freeChunk + self baseHeaderSize. limit := self addressAfter: freeChunk. count := 0. self allHeapEntitiesDo: [:obj| "continue enumerating even if no room so as to unmark all objects." + (gc markObjectsForEnumerationPrimitives - (MarkObjectsForEnumerationPrimitives ifTrue: [self isMarked: obj] ifFalse: [true]) ifTrue: [(self isNormalObject: obj) ifTrue: + [gc markObjectsForEnumerationPrimitives ifTrue: - [MarkObjectsForEnumerationPrimitives ifTrue: [self setIsMarkedOf: obj to: false]. count := count + 1. ptr < limit ifTrue: [self longAt: ptr put: obj. ptr := ptr + self bytesPerOop]] ifFalse: + [gc markObjectsForEnumerationPrimitives ifTrue: - [MarkObjectsForEnumerationPrimitives ifTrue: [(self isSegmentBridge: obj) ifFalse: [self setIsMarkedOf: obj to: false]]]]]. self assert: (self isEmptyObjStack: markStack). + gc markObjectsForEnumerationPrimitives - MarkObjectsForEnumerationPrimitives ifTrue: [self assert: self allObjectsUnmarked. self emptyObjStack: weaklingStack] ifFalse: [self assert: (self isEmptyObjStack: weaklingStack)]. self assert: count >= self numSlotsMask. (count > (ptr - start / self bytesPerOop) "not enough room" or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word" [self freeChunkWithBytes: (self bytesInBody: freeChunk) at: (self startOfObject: freeChunk). self checkFreeSpace: GCModeFull. ^self integerObjectOf: count]. bytes := self largeObjectBytesForSlots: count. start := self startOfObject: freeChunk. self freeChunkWithBytes: limit - start - bytes at: start + bytes. totalFreeOldSpace := totalFreeOldSpace - bytes. self rawOverflowSlotsOf: freeChunk put: count. self set: freeChunk classIndexTo: ClassArrayCompactIndex formatTo: self arrayFormat. + gc maybeModifyGCFlagsOf: freeChunk. self possibleRootStoreInto: freeChunk. self checkFreeSpace: GCModeFull. self runLeakCheckerFor: GCModeFull. ^freeChunk! Item was added: + ----- Method: SpurMemoryManager>>allObjectsWhite (in category 'gc - global') ----- + allObjectsWhite + self allObjectsDo: + [:o| ((self isMarked: o) or: [self isGrey: o]) ifTrue: [bogon := o. ^false]]. + ^true! Item was removed: - ----- Method: SpurMemoryManager>>allStrongSlotsOfWeaklingAreMarked: (in category 'weakness and ephemerality') ----- - allStrongSlotsOfWeaklingAreMarked: aWeakling - "N.B. generateToByDoLimitExpression:negative:on: guards against (unsigned)0 - 1 going +ve" - 0 to: (self numStrongSlotsOfWeakling: aWeakling) - 1 do: - [:i| | referent | - referent := self fetchPointer: i ofObject: aWeakling. - (self isNonImmediate: referent) ifTrue: - [(self isMarked: referent) ifFalse: - [^false]]]. - ^true! Item was added: + ----- Method: SpurMemoryManager>>allStrongSlotsOfWeaklingAreMarked:excludingYoungObjects: (in category 'weakness and ephemerality') ----- + allStrongSlotsOfWeaklingAreMarked: aWeakling excludingYoungObjects: aBoolean + "N.B. generateToByDoLimitExpression:negative:on: guards against (unsigned)0 - 1 going +ve" + 0 to: (self numStrongSlotsOfWeakling: aWeakling) - 1 do: + [:i| | referent | + referent := self fetchPointer: i ofObject: aWeakling. + (self isNonImmediate: referent) ifTrue: + [(self isMarked: referent) ifFalse: + [((self isYoung: referent) and: [aBoolean] ) + ifFalse: [self cCode: 'raise(SIGINT);'. ^false] ]]]. + ^true! Item was added: + ----- Method: SpurMemoryManager>>allUnscannedEphemeronsOnObjStackAreActive (in category 'weakness and ephemerality') ----- + allUnscannedEphemeronsOnObjStackAreActive + + [(self isEmptyObjStack: ephemeronStack) not] + whileTrue: [ | pointer key | + pointer := self popObjStack: ephemeronStack. + key := self keyOfMaybeFiredEphemeron: (self longAt: pointer). + ((self isImmediate: key) or: [self isMarked: key]) ifTrue: + [^false]]. + + + ^true! Item was changed: ----- Method: SpurMemoryManager>>allocateMemoryOfSize:newSpaceSize:stackSize:codeSize: (in category 'spur bootstrap') ----- allocateMemoryOfSize: memoryBytes newSpaceSize: newSpaceBytes stackSize: stackBytes codeSize: codeBytes "Intialize the receiver for bootsraping an image. Set up a large oldSpace and an empty newSpace and set-up freeStart and scavengeThreshold to allocate in oldSpace. Later on (in initializePostBootstrap) freeStart and scavengeThreshold will be set to sane values." <doNotGenerate> self assert: (memoryBytes \\ self allocationUnit = 0 and: [newSpaceBytes \\ self allocationUnit = 0 and: [codeBytes \\ self allocationUnit = 0]]). self allocateMemoryOfSize: memoryBytes + newSpaceBytes + codeBytes + stackBytes. newSpaceStart := codeBytes + stackBytes. endOfMemory := freeOldSpaceStart := memoryBytes + newSpaceBytes + codeBytes + stackBytes. "leave newSpace empty for the bootstrap" freeStart := newSpaceBytes + newSpaceStart. oldSpaceStart := newSpaceBytes + newSpaceStart. scavengeThreshold := memory size * memory bytesPerElement. "i.e. /don't/ scavenge." + + marker := self class markerClass simulatorClass new manager: self; yourself. + scavenger := SpurGenerationScavenger simulatorClass new. scavenger manager: self. scavenger newSpaceStart: newSpaceStart newSpaceBytes: newSpaceBytes survivorBytes: newSpaceBytes // self scavengerDenominator. + + compactor := self class compactorClass simulatorClass new manager: self; yourself. + + gc := self class gcClass simulatorClass new manager: self; marker: marker; compactor: compactor; scavenger: scavenger; yourself. + ! - compactor := self class compactorClass simulatorClass new manager: self; yourself! Item was changed: ----- Method: SpurMemoryManager>>ambiguousClass:allInstancesInto:limit:resultsInto: (in category 'primitive support') ----- ambiguousClass: aClass allInstancesInto: start limit: limit resultsInto: binaryBlock "Dea with ambiguity and normalize indices." <inline: true> | expectedIndex count ptr | count := 0. ptr := start. expectedIndex := self rawHashBitsOf: aClass. self allHeapEntitiesDo: [:obj| | actualIndex | "continue enumerating even if no room so as to unmark all objects and/or normalize class indices." + (gc markObjectsForEnumerationPrimitives - (MarkObjectsForEnumerationPrimitives ifTrue: [self isMarked: obj] ifFalse: [true]) ifTrue: [(self isNormalObject: obj) ifTrue: + [gc markObjectsForEnumerationPrimitives ifTrue: - [MarkObjectsForEnumerationPrimitives ifTrue: [self setIsMarkedOf: obj to: false]. actualIndex := self classIndexOf: obj. (self classOrNilAtIndex: actualIndex) = aClass ifTrue: [actualIndex ~= expectedIndex ifTrue: [self setClassIndexOf: obj to: expectedIndex]. count := count + 1. ptr < limit ifTrue: [self longAt: ptr put: obj. ptr := ptr + self bytesPerOop]]] ifFalse: + [gc markObjectsForEnumerationPrimitives ifTrue: - [MarkObjectsForEnumerationPrimitives ifTrue: [(self isSegmentBridge: obj) ifFalse: [self setIsMarkedOf: obj to: false]]]]]. self purgeDuplicateClassTableEntriesFor: aClass. binaryBlock value: count value: ptr ! Item was changed: ----- Method: SpurMemoryManager>>attemptToShrink (in category 'growing/shrinking memory') ----- attemptToShrink "Attempt to shrink memory after successfully reclaiming lots of memory. + If there's enough memory to shrink then be sure to attempt to shrink by + at least growHeadroom because segments are typically of that size." - If there's enough memory to shrink then be sure to attept to shrink by - at least growHeaqdroom because segments are typically of that size." (totalFreeOldSpace > shrinkThreshold and: [totalFreeOldSpace > growHeadroom and: [segmentManager shrinkObjectMemory: (totalFreeOldSpace - growHeadroom max: growHeadroom)]]) ifTrue: [statShrinkMemory := statShrinkMemory + 1]! Item was changed: ----- Method: SpurMemoryManager>>checkHeapFreeSpaceIntegrity (in category 'debug support') ----- checkHeapFreeSpaceIntegrity + + ^ gc isIncremental + ifTrue: [self checkHeapFreeSpaceIntegrityForIncrementalGC] + ifFalse: [self checkHeapFreeSpaceIntegrityForStopTheWorldGC]! - "Perform an integrity/leak check using the heapMap. Assume clearLeakMapAndMapAccessibleFreeSpace - has set a bit at each free chunk's header. Scan all objects in the heap checking that no pointer points - to a free chunk and that all free chunks that refer to others refer to marked chunks. Answer if all checks pass." - | ok total | - <inline: false> - <var: 'total' type: #usqInt> - ok := true. - total := 0. - 0 to: self numFreeLists - 1 do: - [:i| - (freeLists at: i) ~= 0 ifTrue: - [(heapMap heapMapAtWord: (self pointerForOop: (freeLists at: i))) = 0 ifTrue: - [coInterpreter print: 'leak in free list '; printNum: i; print: ' to non-free '; printHex: (freeLists at: i); eekcr. - ok := false]]]. - - "Excuse the duplication but performance is at a premium and we avoid - some tests by splitting the newSpace and oldSpace enumerations." - self allNewSpaceEntitiesDo: - [:obj| | fieldOop | - (self isFreeObject: obj) - ifTrue: - [coInterpreter print: 'young object '; printHex: obj; print: ' is free'; eekcr. - ok := false] - ifFalse: - [obj ~= freeSpaceCheckOopToIgnore ifTrue: - [0 to: (self numPointerSlotsOf: obj) - 1 do: - [:fi| - fieldOop := self fetchPointer: fi ofObject: obj. - (self isNonImmediate: fieldOop) ifTrue: - [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue: - [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; eekcr. - ok := false]]]]]]. - self allOldSpaceEntitiesDo: - [:obj| | fieldOop | - (self isFreeObject: obj) - ifTrue: - [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue: - [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' is unmapped?!! '; eekcr. - ok := false]. - fieldOop := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj. - (fieldOop ~= 0 - and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: - [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; eekcr. - ok := false]. - (self isLilliputianSize: (self bytesInBody: obj)) ifFalse: - [fieldOop := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: obj. - (fieldOop ~= 0 - and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: - [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; eekcr. - ok := false]]. - (self isLargeFreeObject: obj) ifTrue: - [self freeChunkParentIndex to: self freeChunkLargerIndex do: - [:fi| - fieldOop := self fetchPointer: fi ofFreeChunk: obj. - (fieldOop ~= 0 - and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: - [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is unmapped'; eekcr. - ok := false]]]. - total := total + (self bytesInBody: obj)] - ifFalse: - [obj ~= freeSpaceCheckOopToIgnore ifTrue: - [0 to: (self numPointerSlotsOf: obj) - 1 do: - [:fi| - (self isForwarded: obj) - ifTrue: - [self assert: fi = 0. "I'm now trying to use forwarders in GC algorithms..." - fieldOop := self fetchPointer: fi ofMaybeForwardedObject: obj] - ifFalse: "We keep #fetchPointer:ofObject: API here for assertions" - [fieldOop := self fetchPointer: fi ofObject: obj]. - (self isNonImmediate: fieldOop) ifTrue: - [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue: - [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; eekcr. - ok := false]]]]]]. - total ~= totalFreeOldSpace ifTrue: - [coInterpreter print: 'incorrect totalFreeOldSpace; expected '; printNum: totalFreeOldSpace; print: ' found '; printNum: total; eekcr. - ok := false]. - ^ok! Item was added: + ----- Method: SpurMemoryManager>>checkHeapFreeSpaceIntegrityForIncrementalGC (in category 'debug support') ----- + checkHeapFreeSpaceIntegrityForIncrementalGC + "Perform an integrity/leak check using the heapMap. Assume clearLeakMapAndMapAccessibleFreeSpace + has set a bit at each free chunk's header. Scan all objects in the heap checking that no pointer points + to a free chunk and that all free chunks that refer to others refer to marked chunks. Answer if all checks pass. + + Ignore unmarked objects during sweeping" + | ok total | + <inline: false> + <var: 'total' type: #usqInt> + ok := true. + total := 0. + 0 to: self numFreeLists - 1 do: + [:i| + (freeLists at: i) ~= 0 ifTrue: + [(heapMap heapMapAtWord: (self pointerForOop: (freeLists at: i))) = 0 ifTrue: + [coInterpreter print: 'leak in free list '; printNum: i; print: ' to non-free '; printHex: (freeLists at: i); eekcr. + ok := false]]]. + + "Excuse the duplication but performance is at a premium and we avoid + some tests by splitting the newSpace and oldSpace enumerations." + self allNewSpaceEntitiesDo: + [:obj| | fieldOop | + (self isFreeObject: obj) + ifTrue: + [coInterpreter print: 'young object '; printHex: obj; print: ' is free'; eekcr. + ok := false] + ifFalse: + [obj ~= freeSpaceCheckOopToIgnore ifTrue: + [0 to: (self numPointerSlotsOf: obj) - 1 do: + [:fi| + fieldOop := self fetchPointer: fi ofObject: obj. + (self isNonImmediate: fieldOop) ifTrue: + [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue: + [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; eekcr. + ok := false]]]]]]. + self allOldSpaceEntitiesDo: + [:obj| | fieldOop | + (self isFreeObject: obj) + ifTrue: + [ + (compactor compactor segmentToFill isNil or: [(self objectStartingAt: (compactor compactor segmentToFill segStart)) ~= obj]) + ifTrue: [ + (heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue: + [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' is unmapped?!! '; eekcr. + ok := false]. + fieldOop := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj. + (fieldOop ~= 0 + and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: + [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; eekcr. + ok := false]. + (self isLilliputianSize: (self bytesInBody: obj)) ifFalse: + [fieldOop := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: obj. + (fieldOop ~= 0 + and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: + [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; eekcr. + ok := false]]. + (self isLargeFreeObject: obj) ifTrue: + [self freeChunkParentIndex to: self freeChunkLargerIndex do: + [:fi| + fieldOop := self fetchPointer: fi ofFreeChunk: obj. + (fieldOop ~= 0 + and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: + [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is unmapped'; eekcr. + ok := false]]]. + total := total + (self bytesInBody: obj)]] + + ifFalse: + [(obj ~= freeSpaceCheckOopToIgnore and: + "during sweeping ignore unmarked objects behind the current sweeping position" + [(gc inSweepingAheadOfSweepersPosition: obj) not or: [self isMarked: obj]]) ifTrue: + [0 to: (self numPointerSlotsOf: obj) - 1 do: + [:fi| + (self isForwarded: obj) + ifTrue: + [self assert: fi = 0. "I'm now trying to use forwarders in GC algorithms..." + fieldOop := self fetchPointer: fi ofMaybeForwardedObject: obj] + ifFalse: "We keep #fetchPointer:ofObject: API here for assertions" + [fieldOop := self fetchPointer: fi ofObject: obj]. + (self isNonImmediate: fieldOop) ifTrue: + [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue: + [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; eekcr. + ok := false]]]]]]. + + total - totalFreeOldSpace ~= 0 ifTrue: + [coInterpreter print: 'incorrect totalFreeOldSpace; expected '; printNum: totalFreeOldSpace; print: ' found '; printNum: total; eekcr. + ok := false]. + ^ok! Item was added: + ----- Method: SpurMemoryManager>>checkHeapFreeSpaceIntegrityForStopTheWorldGC (in category 'debug support') ----- + checkHeapFreeSpaceIntegrityForStopTheWorldGC + "Perform an integrity/leak check using the heapMap. Assume clearLeakMapAndMapAccessibleFreeSpace + has set a bit at each free chunk's header. Scan all objects in the heap checking that no pointer points + to a free chunk and that all free chunks that refer to others refer to marked chunks. Answer if all checks pass." + | ok total | + <inline: false> + <var: 'total' type: #usqInt> + ok := true. + total := 0. + 0 to: self numFreeLists - 1 do: + [:i| + (freeLists at: i) ~= 0 ifTrue: + [(heapMap heapMapAtWord: (self pointerForOop: (freeLists at: i))) = 0 ifTrue: + [coInterpreter print: 'leak in free list '; printNum: i; print: ' to non-free '; printHex: (freeLists at: i); eekcr. + ok := false]]]. + + "Excuse the duplication but performance is at a premium and we avoid + some tests by splitting the newSpace and oldSpace enumerations." + self allNewSpaceEntitiesDo: + [:obj| | fieldOop | + (self isFreeObject: obj) + ifTrue: + [coInterpreter print: 'young object '; printHex: obj; print: ' is free'; eekcr. + ok := false] + ifFalse: + [obj ~= freeSpaceCheckOopToIgnore ifTrue: + [0 to: (self numPointerSlotsOf: obj) - 1 do: + [:fi| + fieldOop := self fetchPointer: fi ofObject: obj. + (self isNonImmediate: fieldOop) ifTrue: + [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue: + [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; eekcr. + ok := false]]]]]]. + self allOldSpaceEntitiesDo: + [:obj| | fieldOop | + (self isFreeObject: obj) + ifTrue: + [ + (compactor compactor segmentToFill isNil or: [(self objectStartingAt: (compactor compactor segmentToFill segStart)) ~= obj]) + ifTrue: [ + (heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue: + [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' is unmapped?!! '; eekcr. + ok := false]. + fieldOop := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj. + (fieldOop ~= 0 + and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: + [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; eekcr. + ok := false]. + (self isLilliputianSize: (self bytesInBody: obj)) ifFalse: + [fieldOop := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: obj. + (fieldOop ~= 0 + and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: + [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; eekcr. + ok := false]]. + (self isLargeFreeObject: obj) ifTrue: + [self freeChunkParentIndex to: self freeChunkLargerIndex do: + [:fi| + fieldOop := self fetchPointer: fi ofFreeChunk: obj. + (fieldOop ~= 0 + and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: + [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is unmapped'; eekcr. + ok := false]]]. + total := total + (self bytesInBody: obj)]] + + ifFalse: + [obj ~= freeSpaceCheckOopToIgnore ifTrue: + [0 to: (self numPointerSlotsOf: obj) - 1 do: + [:fi| + (self isForwarded: obj) + ifTrue: + [self assert: fi = 0. "I'm now trying to use forwarders in GC algorithms..." + fieldOop := self fetchPointer: fi ofMaybeForwardedObject: obj] + ifFalse: "We keep #fetchPointer:ofObject: API here for assertions" + [fieldOop := self fetchPointer: fi ofObject: obj]. + (self isNonImmediate: fieldOop) ifTrue: + [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue: + [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; eekcr. + ok := false]]]]]]. + + total - totalFreeOldSpace ~= 0 ifTrue: + [coInterpreter print: 'incorrect totalFreeOldSpace; expected '; printNum: totalFreeOldSpace; print: ' found '; printNum: total; eekcr. + ok := false]. + ^ok! Item was changed: ----- Method: SpurMemoryManager>>checkHeapIntegrity:classIndicesShouldBeValid: (in category 'debug support') ----- (excessive size, no diff calculated) Item was changed: ----- Method: SpurMemoryManager>>classOrNilAtIndex: (in category 'class table') ----- classOrNilAtIndex: classIndex <api> | classTablePage | self assert: (classIndex <= self tagMask or: [classIndex >= self arrayClassIndexPun]). + (classIndex <= self tagMask or: [classIndex >= self arrayClassIndexPun]) + ifFalse: [self cCode: 'raise(SIGINT)']. classTablePage := self fetchPointer: classIndex >> self classTableMajorIndexShift ofObject: hiddenRootsObj. classTablePage = nilObj ifTrue: [^nilObj]. ^self fetchPointer: (classIndex bitAnd: self classTableMinorIndexMask) ofObject: classTablePage! Item was changed: ----- Method: SpurMemoryManager>>classTableFirstPage (in category 'accessing') ----- classTableFirstPage + <cmacro: '() GIV(classTableFirstPage)'> + - <cmacro> ^classTableFirstPage! Item was changed: + ----- Method: SpurMemoryManager>>clearLeakMapAndMapAccessibleFreeSpace (in category 'debug support - leak/mark map') ----- - ----- Method: SpurMemoryManager>>clearLeakMapAndMapAccessibleFreeSpace (in category 'debug support') ----- clearLeakMapAndMapAccessibleFreeSpace "Perform an integrity/leak check using the heapMap. Set a bit at each free chunk's header." <inline: false> heapMap clearHeapMap. self allOldSpaceEntitiesFrom: self firstObject do: [:objOop| (self isFreeObject: objOop) ifTrue: [heapMap heapMapAtWord: (self pointerForOop: objOop) Put: 1]]! Item was changed: + ----- Method: SpurMemoryManager>>clearLeakMapAndMapAccessibleObjects (in category 'debug support - leak/mark map') ----- - ----- Method: SpurMemoryManager>>clearLeakMapAndMapAccessibleObjects (in category 'debug support') ----- clearLeakMapAndMapAccessibleObjects "Perform an integrity/leak check using the heapMap. Set a bit at each object's header." <inline: false> heapMap clearHeapMap. self allObjectsDo: [:oop| heapMap heapMapAtWord: (self pointerForOop: oop) Put: 1]! Item was added: + ----- Method: SpurMemoryManager>>clearLeakMapAndMapToBeMarkedObjects (in category 'debug support - leak/mark map') ----- + clearLeakMapAndMapToBeMarkedObjects + "Perform an integrity check for marked objects using the heapMap. Set a bit at each objects header that should be marked." + <inline: false> + | stackC stackPointerC stackDepthC stackFrameSizeC | + heapMap clearHeapMap. + + stackC := self allocateLargestFreeChunk. + stackFrameSizeC := self bytesInBody: stackC. + stackPointerC := 0. + stackDepthC := 0. + + "push references from roots on stack" + self allNewSpaceObjectsDo: [:objOop | + (self isFreeObject: objOop) not + ifTrue: [ | size | + size := self numStrongSlotsOfInephemeral: objOop. + + 0 to: (size - 1) do: + [:index | | slot | + slot := self fetchPointer: index ofObject: objOop. + + ((self isOldObject: objOop) and: [self isMarked: objOop]) + ifTrue: [heapMap heapMapAtWord: (self pointerForOop: slot) Put: 1. + self storePointerUnchecked: stackPointerC ofObject: stackC withValue: slot. + stackPointerC := stackPointerC + 1]]]]. + + ! Item was changed: ----- Method: SpurMemoryManager>>coInterpreter: (in category 'simulation') ----- coInterpreter: aCoInterpreter <doNotGenerate> coInterpreter := aCoInterpreter. + marker ifNotNil: + [marker coInterpreter: aCoInterpreter]. scavenger ifNotNil: [scavenger coInterpreter: aCoInterpreter]. compactor ifNotNil: + [compactor coInterpreter: aCoInterpreter]. + gc ifNotNil: + [gc coInterpreter: aCoInterpreter]! - [compactor coInterpreter: aCoInterpreter]! Item was added: + ----- Method: SpurMemoryManager>>compactionStartUsecs: (in category 'accessing') ----- + compactionStartUsecs: anInteger + + compactionStartUsecs := anInteger! Item was added: + ----- Method: SpurMemoryManager>>debugGCCollect (in category 'debug support') ----- + debugGCCollect + "empties the heap for writing " + + coInterpreter preGCAction: GCModeFull. + self flushNewSpace. + gc markObjects: true. + scavenger forgetUnmarkedRememberedObjects. + segmentManager prepareForGlobalSweep. + compactor compact. + coInterpreter postGCAction: GCModeFull. + + self assert: self validObjStacks. + self assert: (self isEmptyObjStack: markStack). + self assert: (self isEmptyObjStack: weaklingStack). + self assert: self allObjectsUnmarked.! Item was changed: ----- Method: SpurMemoryManager>>doScavenge: (in category 'gc - scavenging') ----- doScavenge: tenuringCriterion + + <doNotGenerate> + gc doScavenge: tenuringCriterion! - "The inner shell for scavenge, abstrascted out so globalGarbageCollect can use it." - <inline: false> - self doAllocationAccountingForScavenge. - gcPhaseInProgress := ScavengeInProgress. - pastSpaceStart := scavenger scavenge: tenuringCriterion. - self assert: (self - oop: pastSpaceStart - isGreaterThanOrEqualTo: scavenger pastSpace start - andLessThanOrEqualTo: scavenger pastSpace limit). - freeStart := scavenger eden start. - gcPhaseInProgress := 0. - self resetAllocationAccountingAfterGC! Item was changed: ----- Method: SpurMemoryManager>>ensureRoomOnObjStackAt: (in category 'obj stacks') ----- ensureRoomOnObjStackAt: objStackRootIndex "An obj stack is a stack of objects stored in a hidden root slot, such as the markStack or the ephemeronQueue. It is a linked list of segments, with the hot end at the head of the list. It is a word object. The stack pointer is in ObjStackTopx and 0 means empty. The list goes through ObjStackNextx. We don't want to shrink objStacks, since they're used in GC and its good to keep their memory around. So unused pages created by popping emptying pages are kept on the ObjStackFreex list." | stackOrNil freeOrNewPage | stackOrNil := self fetchPointer: objStackRootIndex ofObject: hiddenRootsObj. (stackOrNil = nilObj or: [(self fetchPointer: ObjStackTopx ofObject: stackOrNil) >= ObjStackLimit]) ifTrue: [freeOrNewPage := stackOrNil = nilObj ifTrue: [0] ifFalse: [self fetchPointer: ObjStackFreex ofObject: stackOrNil]. freeOrNewPage ~= 0 ifTrue: "the free page list is always on the new page." [self storePointer: ObjStackFreex ofObjStack: stackOrNil withValue: 0. + self assert: (marker marking not or: [self isMarked: freeOrNewPage])] - self assert: (marking not or: [self isMarked: freeOrNewPage])] ifFalse: [freeOrNewPage := self allocateSlotsInOldSpace: ObjStackPageSlots format: self wordIndexableFormat classIndex: self wordSizeClassIndexPun. freeOrNewPage ifNil: ["Allocate a new segment an retry. This is very uncommon. But it happened to me (Clement)." self growOldSpaceByAtLeast: ObjStackPageSlots. freeOrNewPage := self allocateSlotsInOldSpace: ObjStackPageSlots format: self wordIndexableFormat classIndex: self wordSizeClassIndexPun. freeOrNewPage ifNil: [self error: 'no memory to allocate or extend obj stack']]. self storePointer: ObjStackFreex ofObjStack: freeOrNewPage withValue: 0. + marker marking ifTrue: [self setIsMarkedOf: freeOrNewPage to: true]. + gc maybeModifyGCFlagsOf: freeOrNewPage]. - marking ifTrue: [self setIsMarkedOf: freeOrNewPage to: true]]. self storePointer: ObjStackMyx ofObjStack: freeOrNewPage withValue: objStackRootIndex; storePointer: ObjStackNextx ofObjStack: freeOrNewPage withValue: (stackOrNil = nilObj ifTrue: [0] ifFalse: [stackOrNil]); storePointer: ObjStackTopx ofObjStack: freeOrNewPage withValue: 0; storePointer: objStackRootIndex ofObject: hiddenRootsObj withValue: freeOrNewPage. self assert: (self isValidObjStackAt: objStackRootIndex). "Added a new page; now update and answer the relevant cached first page." stackOrNil := self updateRootOfObjStackAt: objStackRootIndex with: freeOrNewPage]. self assert: (self isValidObjStackAt: objStackRootIndex). ^stackOrNil! Item was added: + ----- Method: SpurMemoryManager>>ephemeronStack (in category 'accessing') ----- + ephemeronStack + + <cmacro: '() GIV(ephemeronStack)'> + ^ ephemeronStack! Item was added: + ----- Method: SpurMemoryManager>>expungeDuplicateAndUnmarkedClasses:ignoringClassesInYoungSpace: (in category 'class table') ----- + expungeDuplicateAndUnmarkedClasses: expungeUnmarked ignoringClassesInYoungSpace: ignoreYounglings + "Bits have been set in the classTableBitmap corresponding to + used classes. Any class in the class table that does not have a + bit set has no instances with that class index. However, becomeForward: + can create duplicate entries, and these duplicate entries wont match their + identityHash. So expunge duplicates by eliminating unmarked entries that + don't occur at their identityHash." + 1 to: numClassTablePages - 1 do: "Avoid expunging the puns by not scanning the 0th page." + [:i| | classTablePage | + classTablePage := self fetchPointer: i ofObject: hiddenRootsObj. + 0 to: self classTablePageSize - 1 do: + [:j| | classOrNil classIndex | + classOrNil := self fetchPointer: j ofObject: classTablePage. + classIndex := i << self classTableMajorIndexShift + j. + self assert: (classOrNil = nilObj or: [coInterpreter addressCouldBeClassObj: classOrNil]). + "only remove a class if it is at a duplicate entry or it is unmarked and we're expunging unmarked classes." + classOrNil = nilObj + ifTrue: + [classIndex < classTableIndex ifTrue: + [classTableIndex := classIndex]] + ifFalse: + [( + (ignoreYounglings and: [self isYoung: classOrNil]) not + and: [(expungeUnmarked and: [(self isMarked: classOrNil) not]) + or: [(self rawHashBitsOf: classOrNil) ~= classIndex]]) ifTrue: + [self storePointerUnchecked: j + ofObject: classTablePage + withValue: nilObj. + "but if it is marked, it should still be in the table at its correct index." + self assert: ((expungeUnmarked and: [(self isMarked: classOrNil) not]) + or: [(self classAtIndex: (self rawHashBitsOf: classOrNil)) = classOrNil]). + "If the removed class is before the classTableIndex, set the + classTableIndex to point to the empty slot so as to reuse it asap." + classIndex < classTableIndex ifTrue: + [classTableIndex := classIndex]]]]]. + "classTableIndex must never index the first page, which is reserved for classes known to the VM." + self assert: classTableIndex >= (1 << self classTableMajorIndexShift)! Item was added: + ----- Method: SpurMemoryManager>>extraRootCount (in category 'accessing') ----- + extraRootCount + + ^ extraRootCount! Item was added: + ----- Method: SpurMemoryManager>>extraRoots (in category 'accessing') ----- + extraRoots + <cmacro: '() GIV(extraRoots)'> + ^ extraRoots! Item was added: + ----- Method: SpurMemoryManager>>firstInstanceWithClassIndex: (in category 'debug printing') ----- + firstInstanceWithClassIndex: classIndex + "Scan the heap printing the oops of any and all objects whose classIndex equals the argument." + <export: true> "useful for VM debugging; use export: not api, so it will be accessible on win32 and won't be written to cointerp.h" + <inline: false> + self allHeapEntitiesDo: + [:obj| + (self classIndexOf: obj) = classIndex ifTrue: + [^ obj]]! Item was added: + ----- Method: SpurMemoryManager>>firstInstanceWithClassOop: (in category 'debug printing') ----- + firstInstanceWithClassOop: classOop + "Scan the heap printing the oops of any and all objects whose classIndex equals the argument." + <export: true> "useful for VM debugging; use export: not api, so it will be accessible on win32 and won't be written to cointerp.h" + <inline: false> + | classIndex | + classIndex := (self rawHashBitsOf: classOop). + self allHeapEntitiesDo: + [:obj| + (self classIndexOf: obj) = classIndex ifTrue: + [^ obj]]! Item was added: + ----- Method: SpurMemoryManager>>firstReferenceTo: (in category 'debug printing') ----- + firstReferenceTo: anOop + "Scan the heap printing the oops of any and all objects that refer to anOop" + <export: true> "useful for VM debugging; use export: not api, so it will be accessible on win32 and won't be written to cointerp.h" + self allObjectsDo: + [:obj| | i | + i := self numPointerSlotsOf: obj. + [(i := i - 1) >= 0] whileTrue: + [anOop = (self fetchPointer: i ofMaybeForwardedObject: obj) ifTrue: + [^ obj]]]! Item was changed: ----- Method: SpurMemoryManager>>followClassTable (in category 'selective compaction') ----- followClassTable "In addition to postBecomeScanClassTable:, I follow the pages in the class table. Because hiddenRootsObj follows nil, false, true and the freeLists, it can never be forwarded." self deny: (self isForwarded: hiddenRootsObj). 0 to: numClassTablePages - 1 do: [:i| | page | page := self followField: i ofObject: hiddenRootsObj. 0 to: (self numSlotsOf: page) - 1 do: [:j| | classOrNil | classOrNil := self fetchPointer: j ofObject: page. + self assert: (self isFreeObject: classOrNil) not. classOrNil ~= nilObj ifTrue: [(self isForwarded: classOrNil) ifTrue: [classOrNil := self followForwarded: classOrNil. self storePointer: j ofObject: page withValue: classOrNil]. (self rawHashBitsOf: classOrNil) = 0 ifTrue: [self storePointerUnchecked: j ofObject: page withValue: nilObj. "If the removed class is before the classTableIndex, set the classTableIndex to point to the empty slot so as to reuse it asap." (i << self classTableMajorIndexShift + j) < classTableIndex ifTrue: [classTableIndex := i << self classTableMajorIndexShift + j]]]]]. "classTableIndex must never index the first page, which is reserved for classes known to the VM." self assert: classTableIndex >= (1 << self classTableMajorIndexShift). self assert: self validClassTableRootPages! Item was changed: ----- Method: SpurMemoryManager>>followForwardedObjStacks (in category 'compaction') ----- followForwardedObjStacks "Compaction will move objStack pages as well as ordinary objects. So they need their slots followed." self followForwardedInObjStack: markStack atIndex: MarkStackRootIndex. self followForwardedInObjStack: weaklingStack atIndex: WeaklingStackRootIndex. + self followForwardedInObjStack: mournQueue atIndex: MournQueueRootIndex. + self followForwardedInObjStack: ephemeronStack atIndex: EphemeronStackRootIndex! - self followForwardedInObjStack: mournQueue atIndex: MournQueueRootIndex! Item was changed: ----- Method: SpurMemoryManager>>forward:to: (in category 'become implementation') ----- forward: obj1 to: obj2 self set: obj1 classIndexTo: self isForwardedObjectClassIndexPun formatTo: self forwardedFormat. self cppIf: IMMUTABILITY ifTrue: [ self setIsImmutableOf: obj1 to: false ]. self storePointer: 0 ofForwarder: obj1 withValue: obj2. + gc maybeModifyForwarder: obj1. "For safety make sure the forwarder has a slot count that includes its contents." (self rawNumSlotsOf: obj1) = 0 ifTrue: [self rawNumSlotsOf: obj1 put: 1]! Item was changed: ----- Method: SpurMemoryManager>>freeChunkWithBytes:at: (in category 'free space') ----- freeChunkWithBytes: bytes at: address <inline: false> | freeChunk | self assert: (self isInOldSpace: address). + (segmentManager segmentContainingObj: address) = (segmentManager segmentContainingObj: address + bytes) + ifFalse: [self cCode: 'raise(SIGINT)']. self assert: (segmentManager segmentContainingObj: address) = (segmentManager segmentContainingObj: address + bytes). freeChunk := self initFreeChunkWithBytes: bytes at: address. self addToFreeList: freeChunk bytes: bytes. self assert: freeChunk = (self objectStartingAt: address). ^freeChunk! Item was added: + ----- Method: SpurMemoryManager>>freeLists (in category 'accessing') ----- + freeLists + + ^ freeLists! Item was added: + ----- Method: SpurMemoryManager>>freeStart: (in category 'accessing') ----- + freeStart: anInteger + + freeStart := anInteger! Item was changed: ----- Method: SpurMemoryManager>>fullGC (in category 'gc - global') ----- fullGC + <doNotGenerate> + + ^ gc fullGC! - "Perform a full eager compacting GC. Answer the size of the largest free chunk." - <returnTypeC: #usqLong> - <inline: #never> "for profiling" - needGCFlag := false. - gcStartUsecs := coInterpreter ioUTCMicrosecondsNow. - statMarkCount := 0. - coInterpreter preGCAction: GCModeFull. - self globalGarbageCollect. - coInterpreter postGCAction: GCModeFull. - statGCEndUsecs := coInterpreter ioUTCMicrosecondsNow. - self updateFullGCStats. - ^(freeLists at: 0) ~= 0 - ifTrue: [self bytesInBody: self findLargestFreeChunk] - ifFalse: [0]! Item was added: + ----- Method: SpurMemoryManager>>gc (in category 'accessing') ----- + gc + + ^ gc! Item was added: + ----- Method: SpurMemoryManager>>gc: (in category 'accessing') ----- + gc: aSpurGarbageCollector + + gc := aSpurGarbageCollector! Item was added: + ----- Method: SpurMemoryManager>>gcMarkEndUsecs: (in category 'accessing') ----- + gcMarkEndUsecs: anInteger + + gcMarkEndUsecs := anInteger! Item was added: + ----- Method: SpurMemoryManager>>gcPhaseInProgress: (in category 'accessing') ----- + gcPhaseInProgress: anInteger + + gcPhaseInProgress := anInteger! Item was added: + ----- Method: SpurMemoryManager>>gcStartUsecs: (in category 'accessing') ----- + gcStartUsecs: anInteger + + gcStartUsecs := anInteger! Item was removed: - ----- Method: SpurMemoryManager>>globalGarbageCollect (in category 'gc - global') ----- - globalGarbageCollect - <inline: true> "inline into fullGC" - self assert: self validObjStacks. - self assert: (self isEmptyObjStack: markStack). - self assert: (self isEmptyObjStack: weaklingStack). - - "Mark objects /before/ scavenging, to empty the rememberedTable of unmarked roots." - self markObjects: true. - gcMarkEndUsecs := coInterpreter ioUTCMicrosecondsNow. - - scavenger forgetUnmarkedRememberedObjects. - - coInterpreter setGCMode: GCModeNewSpace. - self doScavenge: MarkOnTenure. - coInterpreter setGCMode: GCModeFull. - - "Mid-way the leak check must be more lenient. Unmarked classes will have been - expunged from the table, but unmarked instances will not yet have been reclaimed." - self runLeakCheckerFor: GCModeFull - excludeUnmarkedObjs: true - classIndicesShouldBeValid: true. - - compactionStartUsecs := coInterpreter ioUTCMicrosecondsNow. - segmentManager prepareForGlobalSweep. "for notePinned:" - compactor compact. - self attemptToShrink. - self setHeapSizeAtPreviousGC. - - self assert: self validObjStacks. - self assert: (self isEmptyObjStack: markStack). - self assert: (self isEmptyObjStack: weaklingStack). - self assert: self allObjectsUnmarked. - self runLeakCheckerFor: GCModeFull! Item was added: + ----- Method: SpurMemoryManager>>heapGrowthToSizeGCRatio (in category 'accessing') ----- + heapGrowthToSizeGCRatio + + <cmacro: '() GIV(heapGrowthToSizeGCRatio)'> + ^ heapGrowthToSizeGCRatio! Item was added: + ----- Method: SpurMemoryManager>>heapSizeAtPreviousGC (in category 'accessing') ----- + heapSizeAtPreviousGC + + ^ heapSizeAtPreviousGC! Item was added: + ----- Method: SpurMemoryManager>>hiddenRootsObj (in category 'accessing') ----- + hiddenRootsObj + + ^ hiddenRootsObj! Item was changed: ----- Method: SpurMemoryManager>>initialize (in category 'initialization') ----- initialize "We can put all initializations that set something to 0 or to false here. In C all global variables are initialized to 0, and 0 is false." | moreThanEnough | remapBuffer := Array new: RemapBufferSize. remapBufferCount := extraRootCount := 0. "see below" freeListsMask := totalFreeOldSpace := lowSpaceThreshold := 0. checkForLeaks := 0. + needGCFlag := signalLowSpace := false. - needGCFlag := signalLowSpace := marking := false. becomeEffectsFlags := gcPhaseInProgress := validatedIntegerClassFlags := 0. statScavenges := statIncrGCs := statFullGCs := 0. statMaxAllocSegmentTime := 0. statMarkUsecs := statSweepUsecs := statScavengeGCUsecs := statIncrGCUsecs := statFullGCUsecs := statCompactionUsecs := statGCEndUsecs := gcSweepEndUsecs := 0. statSGCDeltaUsecs := statIGCDeltaUsecs := statFGCDeltaUsecs := 0. statGrowMemory := statShrinkMemory := statRootTableCount := statAllocatedBytes := 0. statRootTableOverflows := statMarkCount := statCompactPassCount := statCoalesces := 0. "We can initialize things that are allocated but are lazily initialized." unscannedEphemerons := SpurContiguousObjStack new. "we can initialize things that are virtual in C." scavenger := SpurGenerationScavenger simulatorClass new manager: self; yourself. segmentManager := SpurSegmentManager simulatorClass new manager: self; yourself. compactor := self class compactorClass simulatorClass new manager: self; yourself. + marker := self class markerClass simulatorClass new manager: self; yourself. + gc := self class gcClass simulatorClass new manager: self; marker: marker; compactor: compactor; scavenger: scavenger; yourself. "We can also initialize here anything that is only for simulation." heapMap := CogCheck32BitHeapMap new. "N.B. We *don't* initialize extraRoots because we don't simulate it." "This is needed on 64-bits. We don't want a simulation creating a huge heap by default. By default use 512Mb on 64-bits, 256Mb on 32-bits." moreThanEnough := 1024 * 1024 * 1024 / (16 / self wordSize). "One million dollars, ha ha ha ha ha,... ha, ha ha ha ha, ..." maxOldSpaceSize := self class initializationOptions ifNotNil: [:initOpts| initOpts at: #maxOldSpaceSize ifAbsent: [moreThanEnough]] + ifNil: [moreThanEnough].! - ifNil: [moreThanEnough]! Item was added: + ----- Method: SpurMemoryManager>>initializeEphemeronStack (in category 'gc - global') ----- + initializeEphemeronStack + self ensureRoomOnObjStackAt: EphemeronStackRootIndex! Item was changed: ----- Method: SpurMemoryManager>>initializeObjectMemory: (in category 'initialization') ----- initializeObjectMemory: bytesToShift "Initialize object memory variables at startup time. Assume endOfMemory at al are initialised by the image-reading code via setHeapBase:memoryLimit:endOfMemory:. endOfMemory is assumed to point to the end of the last object in the image. Assume: image reader also initializes the following variables: specialObjectsOop lastHash" <inline: false> | freeListObj | "Catch mis-initializations leading to bad translations to C" self assert: self baseHeaderSize = self baseHeaderSize. self assert: (self maxSlotsForAlloc * self wordSize) asInteger > 0. self bootstrapping ifFalse: [self initSegmentBridgeWithBytes: self bridgeSize at: endOfMemory - self bridgeSize]. segmentManager adjustSegmentSwizzlesBy: bytesToShift. "image may be at a different address; adjust oops for new location" self adjustAllOopsBy: bytesToShift. specialObjectsOop := segmentManager swizzleObj: specialObjectsOop. "heavily used special objects" nilObj := self splObj: NilObject. falseObj := self splObj: FalseObject. trueObj := self splObj: TrueObject. "In Cog we insist that nil, true & false are next to each other (Cogit generates tighter conditional branch code as a result). In addition, Spur places the free lists and class table root page immediately following them." self assert: nilObj = oldSpaceStart. self assert: falseObj = (self oldSpaceObjectAfter: nilObj). self assert: trueObj = (self oldSpaceObjectAfter: falseObj). freeListObj := self oldSpaceObjectAfter: trueObj. self setHiddenRootsObj: (self oldSpaceObjectAfter: freeListObj). markStack := self swizzleObjStackAt: MarkStackRootIndex. weaklingStack := self swizzleObjStackAt: WeaklingStackRootIndex. mournQueue := self swizzleObjStackAt: MournQueueRootIndex. + ephemeronStack := self swizzleObjStackAt: EphemeronStackRootIndex. self assert: self validObjStacks. self assert: (self isEmptyObjStack: markStack). self assert: (self isEmptyObjStack: weaklingStack). + self assert: (self isEmptyObjStack: ephemeronStack). self initializeFreeSpacePostLoad: freeListObj. segmentManager collapseSegmentsPostSwizzle. self updateFreeLists. self computeFreeSpacePostSwizzle. compactor postSwizzleAction. self initializeOldSpaceFirstFree: freeOldSpaceStart. "initializes endOfMemory, freeStart, free space" self initializeNewSpaceVariables. scavenger initializeRememberedSet. segmentManager checkSegments. compactor biasForGC. "These defaults should depend on machine size; e.g. too small on a powerful laptop, too big on a Pi." growHeadroom := 16*1024*1024. "headroom when growing" shrinkThreshold := 32*1024*1024. "free space before shrinking" self setHeapSizeAtPreviousGC. heapGrowthToSizeGCRatio := 0.333333. "By default GC after scavenge if heap has grown by a third since the last GC"! Item was changed: ----- Method: SpurMemoryManager>>isValidObjStackPage:myIndex: (in category 'obj stacks') ----- isValidObjStackPage: objStackPage myIndex: myx "Just check the page itself." <inline: false> (self classIndexOf: objStackPage) = self wordSizeClassIndexPun ifFalse: [objStackInvalidBecause := 'wrong class index'. invalidObjStackPage := objStackPage. ^false]. (self formatOf: objStackPage) = self wordIndexableFormat ifFalse: [objStackInvalidBecause := 'wrong format'. invalidObjStackPage := objStackPage. ^false]. (self numSlotsOfAny: objStackPage) = ObjStackPageSlots ifFalse: [objStackInvalidBecause := 'wrong num slots'. invalidObjStackPage := objStackPage. ^false]. myx = (self fetchPointer: ObjStackMyx ofObject: objStackPage) ifFalse: [objStackInvalidBecause := 'wrong myx'. invalidObjStackPage := objStackPage. ^false]. + (marker marking and: [(self isMarked: objStackPage) not]) ifTrue: - (marking and: [(self isMarked: objStackPage) not]) ifTrue: [objStackInvalidBecause := 'marking but page is unmarked'. invalidObjStackPage := objStackPage. ^false]. ^true! Item was added: + ----- Method: SpurMemoryManager>>isWhite: (in category 'header access') ----- + isWhite: objOop + "The object was not seen by the marker until now" + + ^ ((self isMarked: objOop) or: [self isGrey: objOop]) not! Item was added: + ----- Method: SpurMemoryManager>>lowSpaceThreshold (in category 'accessing') ----- + lowSpaceThreshold + + ^ lowSpaceThreshold! Item was added: + ----- Method: SpurMemoryManager>>makeAllObjectsWhite (in category 'primitive support') ----- + makeAllObjectsWhite + self allHeapEntitiesDo: + [:obj| + (self isWhite: obj) not ifTrue: + [(self isNormalObject: obj) + ifTrue: + [self setIsMarkedOf: obj to: false. + self setIsGreyOf: obj to: false] + ifFalse: + [(self isSegmentBridge: obj) ifFalse: + [self setIsMarkedOf: obj to: false. + self setIsGreyOf: obj to: false]]]]. + ! Item was added: + ----- Method: SpurMemoryManager>>makeWhite: (in category 'header access') ----- + makeWhite: objOop + "The object was not seen by the marker until now" + + self + setIsMarkedOf: objOop to: false; + setIsGreyOf: objOop to: false! Item was removed: - ----- Method: SpurMemoryManager>>markAccessibleObjectsAndFireEphemerons (in category 'gc - global') ----- - markAccessibleObjectsAndFireEphemerons - self assert: marking. - self assert: self validClassTableRootPages. - self assert: segmentManager allBridgesMarked. - self cCode: [] "for debugging markAndTrace: set (MarkStackRecord := OrderedCollection new)" - inSmalltalk: [MarkStackRecord ifNotNil: [MarkStackRecord resetTo: 1]]. - - "This must come first to enable stack page reclamation. It clears - the trace flags on stack pages and so must precede any marking. - Otherwise it will clear the trace flags of reached pages." - coInterpreter initStackPageGC. - self markAndTraceHiddenRoots. - self markAndTraceExtraRoots. - self assert: self validClassTableRootPages. - coInterpreter markAndTraceInterpreterOops: true. - self assert: self validObjStacks. - self markWeaklingsAndMarkAndFireEphemerons. - self assert: self validObjStacks! Item was removed: - ----- Method: SpurMemoryManager>>markAllUnscannedEphemerons (in category 'weakness and ephemerality') ----- - markAllUnscannedEphemerons - "After firing the unscanned ephemerons we must scan-mark them. - The wrinkle is that doing so may add more ephemerons to the set. - So we remove the first element, by overwriting it with the last element, - and decrementing the top, and then markAndTrace its contents." - self assert: (self noUnscannedEphemerons) not. - self assert: self allUnscannedEphemeronsAreActive. - [unscannedEphemerons top > unscannedEphemerons start] whileTrue: - [| ephemeron key lastptr | - ephemeron := self longAt: unscannedEphemerons start. - lastptr := unscannedEphemerons top - self bytesPerOop. - lastptr > unscannedEphemerons start ifTrue: - [self longAt: unscannedEphemerons start put: (self longAt: lastptr)]. - unscannedEphemerons top: lastptr. - key := self followedKeyOfMaybeFiredEphemeron: ephemeron. - self setIsMarkedOf: ephemeron to: false. "to get it to be fully scanned in markAndTrace:" - self - markAndTrace: key; - markAndTrace: ephemeron]! Item was removed: - ----- Method: SpurMemoryManager>>markAndShouldScan: (in category 'gc - global') ----- - markAndShouldScan: objOop - "Helper for markAndTrace:. - Mark the argument, and answer if its fields should be scanned now. - Immediate objects don't need to be marked. - Already marked objects have already been processed. - Pure bits objects don't need scanning, although their class does. - Weak objects should be pushed on the weakling stack. - Anything else need scanning." - | format | - <inline: true> - (self isImmediate: objOop) ifTrue: - [^false]. - "if markAndTrace: is to follow and eliminate forwarding pointers - in its scan it cannot be handed an r-value which is forwarded." - self assert: (self isForwarded: objOop) not. - (self isMarked: objOop) ifTrue: - [^false]. - self setIsMarkedOf: objOop to: true. - format := self formatOf: objOop. - (self isPureBitsFormat: format) ifTrue: "avoid pushing non-pointer objects on the markStack." - ["Avoid tracing classes of non-objects on the heap, e.g. IRC caches, Sista counters." - (self classIndexOf: objOop) > self lastClassIndexPun ifTrue: - [self markAndTraceClassOf: objOop]. - ^false]. - format = self weakArrayFormat ifTrue: "push weaklings on the weakling stack to scan later" - [self push: objOop onObjStack: weaklingStack. - ^false]. - (format = self ephemeronFormat - and: [self activeAndDeferredScan: objOop]) ifTrue: - [^false]. - ^true! Item was changed: ----- Method: SpurMemoryManager>>markAndTrace: (in category 'gc - global') ----- markAndTrace: objOop "Mark the argument, and all objects reachable from it, and any remaining objects + on the mark stack. Follow forwarding pointers in the scan. This behaviour is now + extracted to the SpurMarker hierarchy, so bridge to it." + <doNotGenerate> - on the mark stack. Follow forwarding pointers in the scan." - <api> - <inline: #never> - "if markAndTrace: is to follow and eliminate forwarding pointers - in its scan it cannot be handed an r-value which is forwarded. - The assert for this is in markAndShouldScan:" - (self markAndShouldScan: objOop) ifFalse: - [^self]. + ^marker markAndTrace: objOop! - "Now scan the object, and any remaining objects on the mark stack." - self markLoopFrom: objOop! Item was removed: - ----- Method: SpurMemoryManager>>markAndTraceClassOf: (in category 'gc - global') ----- - markAndTraceClassOf: objOop - "Ensure the class of the argument is marked, pushing it on the markStack if not already marked. - And for one-way become, which can create duplicate entries in the class table, make sure - objOop's classIndex refers to the classObj's actual classIndex. - Note that this is recursive, but the metaclass chain should terminate quickly." - <inline: false> - | classIndex classObj realClassIndex | - classIndex := self classIndexOf: objOop. - classObj := self classOrNilAtIndex: classIndex. - self assert: (coInterpreter objCouldBeClassObj: classObj). - realClassIndex := self rawHashBitsOf: classObj. - (classIndex ~= realClassIndex - and: [classIndex > self lastClassIndexPun]) ifTrue: - [self setClassIndexOf: objOop to: realClassIndex]. - (self isMarked: classObj) ifFalse: - [self setIsMarkedOf: classObj to: true. - self markAndTraceClassOf: classObj. - self push: classObj onObjStack: markStack]! Item was removed: - ----- Method: SpurMemoryManager>>markAndTraceExtraRoots (in category 'gc - global') ----- - markAndTraceExtraRoots - | oop | - self assert: remapBufferCount = 0. - "1 to: remapBufferCount do: - [:i| - oop := remapBuffer at: i. - ((self isImmediate: oop) or: [self isFreeObject: oop]) ifFalse: - [self markAndTrace: oop]]." - 1 to: extraRootCount do: - [:i| - oop := (extraRoots at: i) at: 0. - ((self isImmediate: oop) or: [self isFreeObject: oop]) ifFalse: - [self markAndTrace: oop]]! Item was removed: - ----- Method: SpurMemoryManager>>markAndTraceHiddenRoots (in category 'gc - global') ----- - markAndTraceHiddenRoots - "The hidden roots hold both the class table pages and the obj stacks, - and hence need special treatment. The obj stacks must be marked - specially; their pages must be marked, but only the contents of the - mournQueue should be marked. - - If a class table page is weak we can mark and trace the hiddenRoots, - which will not trace through class table pages because they are weak. - But if class table pages are strong, we must mark the pages and *not* - trace them so that only classes reachable from the true roots will be - marked, and unreachable classes will be left unmarked." - - self markAndTraceObjStack: markStack andContents: false. - self markAndTraceObjStack: weaklingStack andContents: false. - self markAndTraceObjStack: mournQueue andContents: true. - - self setIsMarkedOf: self rememberedSetObj to: true. - self setIsMarkedOf: self freeListsObj to: true. - - (self isWeakNonImm: classTableFirstPage) ifTrue: - [^self markAndTrace: hiddenRootsObj]. - - self setIsMarkedOf: hiddenRootsObj to: true. - self markAndTrace: classTableFirstPage. - 1 to: numClassTablePages - 1 do: - [:i| self setIsMarkedOf: (self fetchPointer: i ofObject: hiddenRootsObj) - to: true]! Item was removed: - ----- Method: SpurMemoryManager>>markAndTraceObjStack:andContents: (in category 'obj stacks') ----- - markAndTraceObjStack: stackOrNil andContents: markAndTraceContents - "An obj stack is a stack of objects stored in a hidden root slot, such - as the markStack or the ephemeronQueue. It is a linked list of - segments, with the hot end at the head of the list. It is a word object. - The stack pointer is in ObjStackTopx and 0 means empty." - <inline: false> - | index field | - stackOrNil = nilObj ifTrue: - [^self]. - self setIsMarkedOf: stackOrNil to: true. - self assert: (self numSlotsOfAny: stackOrNil) = ObjStackPageSlots. - field := self fetchPointer: ObjStackNextx ofObject: stackOrNil. - field ~= 0 ifTrue: - [self markAndTraceObjStack: field andContents: markAndTraceContents]. - field := stackOrNil. - [field := self fetchPointer: ObjStackFreex ofObject: field. - field ~= 0] whileTrue: - [self setIsMarkedOf: field to: true]. - markAndTraceContents ifFalse: - [^self]. - "There are four fixed slots in an obj stack, and a Topx of 0 indicates empty, so - if there were 6 slots in an oop stack, full would be 2, and the last 0-rel index is 5." - index := (self fetchPointer: ObjStackTopx ofObject: stackOrNil) + ObjStackNextx. - [index >= ObjStackFixedSlots] whileTrue: - [field := self followObjField: index ofObject: stackOrNil. - (self isImmediate: field) ifFalse: - [self markAndTrace: field]. - index := index - 1]! Item was removed: - ----- Method: SpurMemoryManager>>markAndTraceWeaklingsFrom: (in category 'weakness and ephemerality') ----- - markAndTraceWeaklingsFrom: startIndex - "Mark weaklings on the weaklingStack, ignoring startIndex - number of elements on the bottom of the stack. Answer - the size of the stack *before* the enumeration began." - ^self objStack: weaklingStack from: startIndex do: - [:weakling| - self deny: (self isForwarded: weakling). - self markAndTraceClassOf: weakling. - "N.B. generateToByDoLimitExpression:negative:on: guards against (unsigned)0 - 1 going +ve" - 0 to: (self numStrongSlotsOfWeakling: weakling) - 1 do: - [:i| | field | - field := self followOopField: i ofObject: weakling. - ((self isImmediate: field) or: [self isMarked: field]) ifFalse: - [self markAndTrace: field]]]! Item was removed: - ----- Method: SpurMemoryManager>>markInactiveEphemerons (in category 'weakness and ephemerality') ----- - markInactiveEphemerons - "Go through the unscanned ephemerons, marking the inactive ones, and - removing them from the unscanned ephemerons. Answer if any inactive - ones were found. We cannot fire the ephemerons until all are found to - be active since scan-marking an inactive ephemeron later in the set may - render a previously-observed active ephemeron as inactive." - | foundInactive ptr | - foundInactive := false. - ptr := unscannedEphemerons start. - [ptr < unscannedEphemerons top] whileTrue: - [| ephemeron key | - key := self followedKeyOfEphemeron: (ephemeron := self longAt: ptr). - ((self isImmediate: key) or: [self isMarked: key]) - ifTrue: - [foundInactive := true. - "Now remove the inactive ephemeron from the set, and scan-mark it. - Scan-marking it may add more ephemerons to the set." - unscannedEphemerons top: unscannedEphemerons top - self bytesPerOop. - unscannedEphemerons top > ptr ifTrue: - [self longAt: ptr put: (self longAt: unscannedEphemerons top)]. - self markAndTrace: ephemeron] - ifFalse: - [ptr := ptr + self bytesPerOop]]. - ^foundInactive! Item was removed: - ----- Method: SpurMemoryManager>>markLoopFrom: (in category 'gc - global') ----- - markLoopFrom: objOop - "Scan objOop and all objects on the mark stack, until the mark stack is empty. - N.B. When the incremental GC is written this will probably be refactored as - markLoopFrom: objOop while: aBlock" - <inline: true> - | objToScan field index numStrongSlots scanLargeObject | - - "Now scan the object, and any remaining objects on the mark stack." - objToScan := objOop. - "To avoid overflowing the mark stack when we encounter large objects, we - push the obj, then its numStrongSlots, and then index the object from the stack." - [(self isImmediate: objToScan) - ifTrue: [scanLargeObject := true] - ifFalse: - [numStrongSlots := self numStrongSlotsOfInephemeral: objToScan. - scanLargeObject := numStrongSlots > self traceImmediatelySlotLimit]. - scanLargeObject - ifTrue: "scanning a large object. scan until hitting an unmarked object, then switch to it, if any." - [(self isImmediate: objToScan) - ifTrue: - [index := self integerValueOf: objToScan. - objToScan := self topOfObjStack: markStack] - ifFalse: - [index := numStrongSlots. - self markAndTraceClassOf: objToScan]. - [index > 0] whileTrue: - [index := index - 1. - field := self fetchPointer: index ofObject: objToScan. - (self isNonImmediate: field) ifTrue: - [(self isForwarded: field) ifTrue: "fixFollowedField: is /not/ inlined" - [field := self fixFollowedField: index ofObject: objToScan withInitialValue: field]. - (self markAndShouldScan: field) ifTrue: - [index > 0 ifTrue: - [(self topOfObjStack: markStack) ~= objToScan ifTrue: - [self push: objToScan onObjStack: markStack]. - self push: (self integerObjectOf: index) onObjStack: markStack]. - objToScan := field. - index := -1]]]. - index >= 0 ifTrue: "if loop terminated without finding an unmarked referent, switch to top of stack." - [objToScan := self popObjStack: markStack. - objToScan = objOop ifTrue: - [objToScan := self popObjStack: markStack]]] - ifFalse: "scanning a small object. scan, marking, pushing unmarked referents, then switch to the top of the stack." - [index := numStrongSlots. - self markAndTraceClassOf: objToScan. - [index > 0] whileTrue: - [index := index - 1. - field := self fetchPointer: index ofObject: objToScan. - (self isNonImmediate: field) ifTrue: - [(self isForwarded: field) ifTrue: "fixFollowedField: is /not/ inlined" - [field := self fixFollowedField: index ofObject: objToScan withInitialValue: field]. - (self markAndShouldScan: field) ifTrue: - [self push: field onObjStack: markStack. - ((self rawNumSlotsOf: field) > self traceImmediatelySlotLimit - and: [(numStrongSlots := self numStrongSlotsOfInephemeral: field) > self traceImmediatelySlotLimit]) ifTrue: - [self push: (self integerObjectOf: numStrongSlots) onObjStack: markStack]]]]. - objToScan := self popObjStack: markStack]. - objToScan notNil] whileTrue! Item was removed: - ----- Method: SpurMemoryManager>>markObjects: (in category 'gc - global') ----- - markObjects: objectsShouldBeUnmarkedAndUnmarkedClassesShouldBeExpunged - <inline: #never> "for profiling" - "Mark all accessible objects. objectsShouldBeUnmarkedAndUnmarkedClassesShouldBeExpunged - is true if all objects are unmarked and/or if unmarked classes shoud be removed from the class table." - "If the incremental collector is running mark bits may be set; stop it and clear them if necessary." - self cCode: '' inSmalltalk: [coInterpreter transcript nextPutAll: 'marking...'; flush]. - self runLeakCheckerFor: GCModeFull. - - self shutDownGlobalIncrementalGC: objectsShouldBeUnmarkedAndUnmarkedClassesShouldBeExpunged. - self initializeUnscannedEphemerons. - self initializeMarkStack. - self initializeWeaklingStack. - marking := true. - self markAccessibleObjectsAndFireEphemerons. - self expungeDuplicateAndUnmarkedClasses: objectsShouldBeUnmarkedAndUnmarkedClassesShouldBeExpunged. - self nilUnmarkedWeaklingSlots. - marking := false! Item was added: + ----- Method: SpurMemoryManager>>markObjectsForEnumerationPrimitives (in category 'gc - incremental') ----- + markObjectsForEnumerationPrimitives + + <doNotGenerate> + ^ MarkObjectsForEnumerationPrimitives! Item was changed: ----- Method: SpurMemoryManager>>markObjectsIn: (in category 'image segment in/out') ----- markObjectsIn: arrayOfRoots "This is part of storeImageSegmentInto:outPointers:roots:." + self uncheckedSetIsMarkedOf: arrayOfRoots to: true. - self setIsMarkedOf: arrayOfRoots to: true. 0 to: (self numSlotsOf: arrayOfRoots) - 1 do: [:i| | oop | oop := self followField: i ofObject: arrayOfRoots. (self isNonImmediate: oop) ifTrue: + [self uncheckedSetIsMarkedOf: oop to: true]]! - [self setIsMarkedOf: oop to: true]]! Item was changed: ----- Method: SpurMemoryManager>>markStack (in category 'spur bootstrap') ----- markStack + + <cmacro: '() GIV(markStack)'> ^markStack! Item was removed: - ----- Method: SpurMemoryManager>>markWeaklingsAndMarkAndFireEphemerons (in category 'gc - global') ----- - markWeaklingsAndMarkAndFireEphemerons - "After the initial scan-mark is complete ephemerons can be processed. - Weaklings have accumulated on the weaklingStack, but more may be - uncovered during ephemeron processing. So trace the strong slots - of the weaklings, and as ephemerons are processed ensure any newly - reached weaklings are also traced." - | numTracedWeaklings | - <inline: false> - numTracedWeaklings := 0. - [coInterpreter markAndTraceUntracedReachableStackPages. - coInterpreter markAndTraceMachineCodeOfMarkedMethods. - "Make sure all reached weaklings have their strong slots traced before firing ephemerons..." - [numTracedWeaklings := self markAndTraceWeaklingsFrom: numTracedWeaklings. - (self sizeOfObjStack: weaklingStack) > numTracedWeaklings] whileTrue. - self noUnscannedEphemerons ifTrue: - [coInterpreter - markAndTraceUntracedReachableStackPages; - markAndTraceMachineCodeOfMarkedMethods; - freeUntracedStackPages; - freeUnmarkedMachineCode. - ^self]. - self markInactiveEphemerons ifFalse: - [self fireAllUnscannedEphemerons]. - self markAllUnscannedEphemerons] - repeat! Item was added: + ----- Method: SpurMemoryManager>>marker (in category 'accessing') ----- + marker + + ^ marker! Item was added: + ----- Method: SpurMemoryManager>>needGCFlag: (in category 'accessing') ----- + needGCFlag: anInteger + + needGCFlag := anInteger ~= 0! Item was added: + ----- Method: SpurMemoryManager>>nilObj (in category 'accessing') ----- + nilObj + + ^ nilObj! Item was removed: - ----- Method: SpurMemoryManager>>nilUnmarkedWeaklingSlots (in category 'weakness and ephemerality') ----- - nilUnmarkedWeaklingSlots - "Nil the unmarked slots in the weaklings on the - weakling stack, finalizing those that lost references. - Finally, empty the weaklingStack." - <inline: #never> "for profiling" - self cCode: '' inSmalltalk: [coInterpreter transcript nextPutAll: 'nilling...'; flush]. - self eassert: [self allOldMarkedWeakObjectsOnWeaklingStack]. - weaklingStack = nilObj ifTrue: - [^self]. - self objStack: weaklingStack from: 0 do: - [:weakling| | anyUnmarked | - anyUnmarked := self nilUnmarkedWeaklingSlotsIn: weakling. - anyUnmarked ifTrue: - ["fireFinalization: could grow the mournQueue and if so, - additional pages must be marked to avoid being GC'ed." - self assert: marking. - coInterpreter fireFinalization: weakling]]. - self emptyObjStack: weaklingStack! Item was added: + ----- Method: SpurMemoryManager>>nilUnmarkedWeaklingSlotsExcludingYoungObjects: (in category 'weakness and ephemerality') ----- + nilUnmarkedWeaklingSlotsExcludingYoungObjects: aBoolean + "Nil the unmarked slots in the weaklings on the + weakling stack, finalizing those that lost references. + Finally, empty the weaklingStack." + <inline: #never> "for profiling" + self cCode: '' inSmalltalk: [coInterpreter transcript nextPutAll: 'nilling...'; flush]. + self eassert: [self allOldMarkedWeakObjectsOnWeaklingStack]. + weaklingStack = nilObj ifTrue: + [^self]. + self objStack: weaklingStack from: 0 do: + [:weakling| | anyUnmarked | + anyUnmarked := self nilUnmarkedWeaklingSlotsIn: weakling excludingYoungObjects: aBoolean. + anyUnmarked ifTrue: + ["fireFinalization: could grow the mournQueue and if so, + additional pages must be marked to avoid being GC'ed." + self assert: marker marking. + coInterpreter fireFinalization: weakling]]. + self emptyObjStack: weaklingStack! Item was removed: - ----- Method: SpurMemoryManager>>nilUnmarkedWeaklingSlotsIn: (in category 'weakness and ephemerality') ----- - nilUnmarkedWeaklingSlotsIn: aWeakling - "Nil the unmarked slots in aWeakling and - answer if any unmarked slots were found." - <inline: true> - | anyUnmarked | - anyUnmarked := false. - self assert: (self allStrongSlotsOfWeaklingAreMarked: aWeakling). - "N.B. generateToByDoLimitExpression:negative:on: guards against (unsigned)0 - 1 going +ve" - (self numStrongSlotsOfWeakling: aWeakling) to: (self numSlotsOf: aWeakling) - 1 do: - [:i| | referent | - referent := self fetchPointer: i ofObject: aWeakling. - (self isNonImmediate: referent) ifTrue: - [(self isUnambiguouslyForwarder: referent) ifTrue: - [referent := self fixFollowedField: i ofObject: aWeakling withInitialValue: referent]. - ((self isImmediate: referent) or: [self isMarked: referent]) ifFalse: - [self storePointerUnchecked: i ofObject: aWeakling withValue: nilObj. - anyUnmarked := true]]]. - ^anyUnmarked! Item was added: + ----- Method: SpurMemoryManager>>nilUnmarkedWeaklingSlotsIn:excludingYoungObjects: (in category 'weakness and ephemerality') ----- + nilUnmarkedWeaklingSlotsIn: aWeakling excludingYoungObjects: aBoolean + "Nil the unmarked slots in aWeakling and + answer if any unmarked slots were found." + <inline: true> + | anyUnmarked | + anyUnmarked := false. + self assert: (self allStrongSlotsOfWeaklingAreMarked: aWeakling excludingYoungObjects: aBoolean). + "N.B. generateToByDoLimitExpression:negative:on: guards against (unsigned)0 - 1 going +ve" + (self numStrongSlotsOfWeakling: aWeakling) to: (self numSlotsOf: aWeakling) - 1 do: + [:i| | referent | + referent := self fetchPointer: i ofObject: aWeakling. + (self isNonImmediate: referent) ifTrue: + [(self isUnambiguouslyForwarder: referent) ifTrue: + [referent := self fixFollowedField: i ofObject: aWeakling withInitialValue: referent]. + ((self isImmediate: referent) or: [self isMarked: referent]) ifFalse: + [((self isYoung: referent) and: [aBoolean]) + ifFalse: [self storePointerUnchecked: i ofObject: aWeakling withValue: nilObj. + anyUnmarked := true]]]]. + ^anyUnmarked! Item was added: + ----- Method: SpurMemoryManager>>numClassTablePages (in category 'accessing') ----- + numClassTablePages + + ^ numClassTablePages! Item was changed: ----- Method: SpurMemoryManager>>objectsReachableFromRoots: (in category 'image segment in/out') ----- objectsReachableFromRoots: arrayOfRoots "This is part of storeImageSegmentInto:outPointers:roots:. Answer an Array of all the objects only reachable from the argument, an Array of root objects, starting with arrayOfRoots. If there is no space, answer a SmallInteger whose value is the number of slots required. This is used to collect the objects to include in an image segment on Spur, separate from creating the segment, hence simplifying the implementation. Thanks to Igor Stasenko for this idea." | freeChunk ptr start limit count oop objOop | <var: #freeChunk type: #usqInt> "& hence start & ptr are too; limit is also because of addressAfter:" <inline: #never> self assert: (self isArray: arrayOfRoots). "Mark all objects except those only reachable from the arrayOfRoots by marking each object in arrayOfRoots and then marking all reachable objects (from the system roots). This leaves unmarked only objects reachable from the arrayOfRoots. N.B. A side-effect of the marking is that all forwarders in arrayOfRoots will be followed." self assert: self allObjectsUnmarked. self markObjectsIn: arrayOfRoots. + gc markObjectsCompletely. - self markObjects: false. "After the mark phase all unreachable weak slots will have been nilled and all active ephemerons fired." self assert: (self isEmptyObjStack: markStack). self assert: (self isEmptyObjStack: weaklingStack). self assert: self noUnscannedEphemerons. "Now unmark the roots before collecting the transitive closure of unmarked objects accessible from the roots." self unmarkObjectsIn: arrayOfRoots. "Use the largest free chunk to answer the result." freeChunk := self allocateLargestFreeChunk. "N.B. Does /not/ update totalFreeOldSpace" totalFreeOldSpace := totalFreeOldSpace - (self bytesInBody: freeChunk). "but must update so that growth in the markStack does not cause assert fails." ptr := start := freeChunk + self baseHeaderSize. limit := self addressAfter: freeChunk. count := 0. "First put the arrayOfRoots; order is important." self noCheckPush: arrayOfRoots onObjStack: markStack. "Now collect the roots and the transitive closure of unmarked objects from them." [self isEmptyObjStack: markStack] whileFalse: [objOop := self popObjStack: markStack. self assert: (self isMarked: objOop). count := count + 1. ptr < limit ifTrue: [self longAt: ptr put: objOop. ptr := ptr + self bytesPerOop]. oop := self fetchClassOfNonImm: objOop. (self isMarked: oop) ifFalse: [self setIsMarkedOf: oop to: true. self noCheckPush: oop onObjStack: markStack]. ((self isContextNonImm: objOop) and: [coInterpreter isStillMarriedContext: objOop]) "widow now, before the copy loop" ifTrue: [0 to: (coInterpreter numSlotsOfMarriedContext: objOop) - 1 do: [:i| oop := coInterpreter fetchPointer: i ofMarriedContext: objOop. ((self isImmediate: oop) or: [self isMarked: oop]) ifFalse: [self setIsMarkedOf: oop to: true. self noCheckPush: oop onObjStack: markStack]]] ifFalse: [0 to: (self numPointerSlotsOf: objOop) - 1 do: [:i| oop := self fetchPointer: i ofObject: objOop. ((self isImmediate: oop) or: [self isMarked: oop]) ifFalse: [self setIsMarkedOf: oop to: true. self noCheckPush: oop onObjStack: markStack]]]]. self unmarkAllObjects. "Now try and allocate the result" (count > (ptr - start / self bytesPerOop) "not enough room" or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word" [self freeObject: freeChunk. self checkFreeSpace: GCCheckImageSegment. ^self integerObjectOf: count]. "There's room; set the format, & classIndex and shorten." self setFormatOf: freeChunk to: self arrayFormat. self setClassIndexOf: freeChunk to: ClassArrayCompactIndex. + gc maybeModifyGCFlagsOf: freeChunk. self shorten: freeChunk toIndexableSize: count. (self isForwarded: freeChunk) ifTrue: [freeChunk := self followForwarded: freeChunk]. self possibleRootStoreInto: freeChunk. self checkFreeSpace: GCCheckImageSegment. self runLeakCheckerFor: GCCheckImageSegment. ^freeChunk! Item was added: + ----- Method: SpurMemoryManager>>oldSpaceObjectCount (in category 'debug printing') ----- + oldSpaceObjectCount + + | num | + num := 0. + self allOldSpaceObjectsDo: [:ea | num := num+1]. + ^ num! Item was added: + ----- Method: SpurMemoryManager>>pastSpaceStart: (in category 'accessing') ----- + pastSpaceStart: anInteger + + pastSpaceStart := anInteger! Item was added: + ----- Method: SpurMemoryManager>>preGlobalGCActions (in category 'gc - global') ----- + preGlobalGCActions + <doNotGenerate>! Item was changed: ----- Method: SpurMemoryManager>>prepareObjStacksForPlanningCompactor (in category 'compaction') ----- prepareObjStacksForPlanningCompactor "SpurPlanningCompactor overwrites the first fields of all moved objects, and saves these fields in a data structure from which they can only be retrieved while scanning the heap. The first field of an objStack page is its stack index, and so to know how many fields in an objStack page to update it is necessary to save the ObjStackTopx field somewhere temporarily. We use the hash field." self prepareObjStackForPlanningCompactor: markStack; prepareObjStackForPlanningCompactor: weaklingStack; + prepareObjStackForPlanningCompactor: mournQueue; + prepareObjStackForPlanningCompactor: ephemeronStack! - prepareObjStackForPlanningCompactor: mournQueue! Item was added: + ----- Method: SpurMemoryManager>>printRelativePositionOf: (in category 'debug printing') ----- + printRelativePositionOf: obj + + coInterpreter cr; print: 'Object is in segment with index: '; printNum: (segmentManager segmentIndexContainingObj: obj); tab; cr; flush. + coInterpreter cr; print: 'It''s relative position in the segment is: '; printHex: obj - (segmentManager segmentContainingObj: obj) segStart; tab; cr; flush.! Item was changed: ----- Method: SpurMemoryManager>>relocateObjStacksForPlanningCompactor (in category 'compaction') ----- relocateObjStacksForPlanningCompactor "Relocate all non-empty objStack pages, following the objStacks from the roots." markStack := self relocateObjStackForPlanningCompactor: markStack andContents: false. weaklingStack := self relocateObjStackForPlanningCompactor: weaklingStack andContents: false. + mournQueue := self relocateObjStackForPlanningCompactor: mournQueue andContents: true. + ephemeronStack := self relocateObjStackForPlanningCompactor: ephemeronStack andContents: true.! - mournQueue := self relocateObjStackForPlanningCompactor: mournQueue andContents: true! Item was changed: ----- Method: SpurMemoryManager>>scavengingGCTenuringIf: (in category 'gc - scavenging') ----- scavengingGCTenuringIf: tenuringCriterion + + <doNotGenerate> + gc scavengingGCTenuringIf: tenuringCriterion! - "Run the scavenger." - <inline: false> - self assert: remapBufferCount = 0. - (self asserta: scavenger eden limit - freeStart > coInterpreter interpreterAllocationReserveBytes) ifFalse: - [coInterpreter tab; - printNum: scavenger eden limit - freeStart; space; - printNum: coInterpreter interpreterAllocationReserveBytes; space; - printNum: coInterpreter interpreterAllocationReserveBytes - (scavenger eden limit - freeStart); cr]. - self checkMemoryMap. - self checkFreeSpace: GCModeNewSpace. - self runLeakCheckerFor: GCModeNewSpace. - - coInterpreter - preGCAction: GCModeNewSpace; - "would prefer this to be in mapInterpreterOops, but - compatibility with ObjectMemory dictates it goes here." - flushMethodCacheFrom: newSpaceStart to: oldSpaceStart. - needGCFlag := false. - - gcStartUsecs := coInterpreter ioUTCMicrosecondsNow. - - self doScavenge: tenuringCriterion. - - statScavenges := statScavenges + 1. - statGCEndUsecs := coInterpreter ioUTCMicrosecondsNow. - statSGCDeltaUsecs := statGCEndUsecs - gcStartUsecs. - statScavengeGCUsecs := statScavengeGCUsecs + statSGCDeltaUsecs. - statRootTableCount := scavenger rememberedSetSize. - - scavenger logScavenge. - - coInterpreter postGCAction: GCModeNewSpace. - - self runLeakCheckerFor: GCModeNewSpace. - self checkFreeSpace: GCModeNewSpace! Item was changed: ----- Method: SpurMemoryManager>>shutDownGlobalIncrementalGC: (in category 'gc - incremental') ----- shutDownGlobalIncrementalGC: objectsShouldBeUnmarked "If the incremental collector is running mark bits may be set; stop it and clear them if necessary." self flag: 'need to implement the global inc GC first...'. objectsShouldBeUnmarked ifTrue: + [self makeAllObjectsWhite. + self assert: self allObjectsUnmarked]! - [self assert: self allObjectsUnmarked]! Item was added: + ----- Method: SpurMemoryManager>>statGCEndUsecs: (in category 'accessing') ----- + statGCEndUsecs: anInteger + + statGCEndUsecs := anInteger! Item was added: + ----- Method: SpurMemoryManager>>statMarkCount: (in category 'accessing') ----- + statMarkCount: anInteger + + statMarkCount := anInteger! Item was added: + ----- Method: SpurMemoryManager>>statRootTableCount: (in category 'accessing') ----- + statRootTableCount: anInteger + + statRootTableCount := anInteger! Item was added: + ----- Method: SpurMemoryManager>>statSGCDeltaUsecs: (in category 'accessing') ----- + statSGCDeltaUsecs: anInteger + + statSGCDeltaUsecs := anInteger! Item was added: + ----- Method: SpurMemoryManager>>statScavengeGCUsecs: (in category 'accessing') ----- + statScavengeGCUsecs: anInteger + + statScavengeGCUsecs := anInteger! Item was added: + ----- Method: SpurMemoryManager>>statScavenges: (in category 'accessing') ----- + statScavenges: anInteger + + statScavenges := anInteger! Item was changed: ----- Method: SpurMemoryManager>>storePointer:ofObjStack:withValue: (in category 'object access') ----- storePointer: fieldIndex ofObjStack: objStackPage withValue: thang self assert: (self formatOf: objStackPage) = self wordIndexableFormat. self cCode: '' inSmalltalk: [fieldIndex caseOf: { [ObjStackTopx] -> [self assert: (thang between: 0 and: ObjStackLimit)]. + [ObjStackMyx] -> [self assert: (thang between: MarkStackRootIndex and: EphemeronStackRootIndex)]. - [ObjStackMyx] -> [self assert: (thang between: MarkStackRootIndex and: MournQueueRootIndex)]. [ObjStackFreex] -> [self assert: (thang = 0 or: [(self addressCouldBeObj: thang) and: [(self numSlotsOfAny: thang) = ObjStackPageSlots and: [(self formatOf: thang) = self wordIndexableFormat]]])]. [ObjStackNextx] -> [self assert: (thang = 0 or: [(self addressCouldBeObj: thang) and: [(self numSlotsOfAny: thang) = ObjStackPageSlots and: [(self formatOf: thang) = self wordIndexableFormat]]])]. } otherwise: []]. ^self longAt: objStackPage + self baseHeaderSize + (fieldIndex << self shiftForWord) put: thang! Item was changed: ----- Method: SpurMemoryManager>>storePointer:ofObject:withValue: (in category 'object access') ----- storePointer: fieldIndex ofObject: objOop withValue: valuePointer "Note must check here for stores of young objects into old ones." + <inline: true> + self assert: (self isForwarded: objOop) not. (self isOldObject: objOop) ifTrue: "most stores into young objects" [(self isYoung: valuePointer) ifTrue: [self possibleRootStoreInto: objOop]]. + self - ^self longAt: objOop + self baseHeaderSize + (fieldIndex << self shiftForWord) + put: valuePointer. + + self marker writeBarrierFor: objOop at: fieldIndex with: valuePointer. + + ^ valuePointer! - put: valuePointer! Item was changed: ----- Method: SpurMemoryManager>>storePointerImmutabilityCheck:ofObject:withValue: (in category 'object access') ----- storePointerImmutabilityCheck: fieldIndex ofObject: objOop withValue: valuePointer "Note must check here for stores of young objects into old ones." <inline: true> "Must be inlined for the normal send in cannotAssign:to:withIndex:" self cppIf: IMMUTABILITY ifTrue: [self deny: (self isImmediate: objOop). (self isImmutable: objOop) ifTrue: [^coInterpreter cannotAssign: valuePointer to: objOop withIndex: fieldIndex]]. self storePointer: fieldIndex ofObject: objOop withValue: valuePointer! Item was changed: ----- Method: SpurMemoryManager>>sufficientSpaceAfterGC: (in category 'gc - scavenging') ----- sufficientSpaceAfterGC: numBytes "This is ObjectMemory's funky entry-point into its incremental GC, which is a stop-the-world a young generation reclaimer. In Spur we run the scavenger. Answer if space is not low." + <doNotGenerate> + ^ gc sufficientSpaceAfterGC: numBytes! - | heapSizePostGC | - self assert: numBytes = 0. - self scavengingGCTenuringIf: TenureByAge. - heapSizePostGC := segmentManager totalOldSpaceCapacity - totalFreeOldSpace. - (heapSizePostGC - heapSizeAtPreviousGC) asFloat / heapSizeAtPreviousGC >= heapGrowthToSizeGCRatio - ifTrue: [self fullGC] "fullGC will attempt to shrink" - ifFalse: "Also attempt to shrink if there is plenty of free space and no need to GC" - [totalFreeOldSpace > (shrinkThreshold * 2) ifTrue: - [self attemptToShrink. - ^true]]. - [totalFreeOldSpace < growHeadroom - and: [(self growOldSpaceByAtLeast: 0) notNil]] whileTrue: - [totalFreeOldSpace >= growHeadroom ifTrue: - [^true]]. - lowSpaceThreshold > totalFreeOldSpace ifTrue: "space is low" - [lowSpaceThreshold := 0. "avoid signalling low space twice" - ^false]. - ^true! Item was changed: ----- Method: SpurMemoryManager>>totalFreeOldSpace (in category 'debug support') ----- totalFreeOldSpace + + <cmacro: '() GIV(totalFreeOldSpace)'> - <doNotGenerate> ^ totalFreeOldSpace! Item was removed: - ----- Method: SpurMemoryManager>>traceImmediatelySlotLimit (in category 'gc - global') ----- - traceImmediatelySlotLimit - "Arbitrary level at which to defer tracing large objects until later. - The average slot size of Smalltalk objects is typically near 8. - We do require traceImmediatelySlotLimit to be < numSlotsMask." - ^64! Item was added: + ----- Method: SpurMemoryManager>>uncheckedSetIsMarkedOf:to: (in category 'header access') ----- + uncheckedSetIsMarkedOf: objOop to: aBoolean + "make no check if it is ok to set marked bit in current gc phase. Needed for SpurMemoryManager>>objectsReachableFromRoots: where we + make a allAtOnce Marking. During this our assumption of not marking young objects is violated, but that is ok because they get manually unmarked in this + method too" + + self subclassResponsibility! Item was changed: ----- Method: SpurMemoryManager>>uniqueIndex:allInstancesInto:limit:resultsInto: (in category 'primitive support') ----- uniqueIndex: classIndex allInstancesInto: start limit: limit resultsInto: binaryBlock <inline: true> | count ptr | count := 0. ptr := start. self allHeapEntitiesDo: [:obj| "continue enumerating even if no room so as to unmark all objects." + (gc markObjectsForEnumerationPrimitives - (MarkObjectsForEnumerationPrimitives ifTrue: [self isMarked: obj] ifFalse: [true]) ifTrue: [(self isNormalObject: obj) ifTrue: + [gc markObjectsForEnumerationPrimitives ifTrue: - [MarkObjectsForEnumerationPrimitives ifTrue: [self setIsMarkedOf: obj to: false]. (self classIndexOf: obj) = classIndex ifTrue: [count := count + 1. ptr < limit ifTrue: [self longAt: ptr put: obj. ptr := ptr + self bytesPerOop]]] ifFalse: + [gc markObjectsForEnumerationPrimitives ifTrue: - [MarkObjectsForEnumerationPrimitives ifTrue: [(self isSegmentBridge: obj) ifFalse: [self setIsMarkedOf: obj to: false]]]]]. binaryBlock value: count value: ptr ! Item was added: + ----- Method: SpurMemoryManager>>unscannedEphemerons (in category 'accessing') ----- + unscannedEphemerons + <cmacro: '() GIV(unscannedEphemerons)'> + ^ unscannedEphemerons! Item was changed: ----- Method: SpurMemoryManager>>updateRootOfObjStackAt:with: (in category 'obj stacks') ----- updateRootOfObjStackAt: objStackRootIndex with: newRootPage self storePointer: objStackRootIndex ofObject: hiddenRootsObj withValue: newRootPage. objStackRootIndex caseOf: { [MarkStackRootIndex] -> [markStack := newRootPage]. [WeaklingStackRootIndex] -> [weaklingStack := newRootPage]. + [MournQueueRootIndex] -> [mournQueue := newRootPage]. + [EphemeronStackRootIndex] -> [ephemeronStack := newRootPage] }. - [MournQueueRootIndex] -> [mournQueue := newRootPage] }. ^newRootPage! Item was changed: ----- Method: SpurMemoryManager>>validObjStacks (in category 'obj stacks') ----- validObjStacks ^(markStack = nilObj or: [self isValidObjStack: markStack]) and: [(weaklingStack = nilObj or: [self isValidObjStack: weaklingStack]) + and: [(mournQueue = nilObj or: [self isValidObjStack: mournQueue]) + and: [ephemeronStack = nilObj or: [self isValidObjStack: ephemeronStack]]]]! - and: [mournQueue = nilObj or: [self isValidObjStack: mournQueue]]]! Item was added: + ----- Method: SpurMemoryManager>>validObjectColors (in category 'debug support') ----- + validObjectColors + + | currentSweepingEntityT | + + currentSweepingEntityT := gc compactor sweeper currentSweepingEntity ifNil: [self firstObject]. + + + self allOldSpaceEntitiesFrom: currentSweepingEntityT do: [:obj | + ((self isMarked: obj) and: [(self isPointers: obj) and: [(self isContext: obj) not]]) + ifTrue: [| slotCount | + slotCount := self numSlotsOf: obj. + + 0 to: slotCount - 1 + do: [:index | | slot | + slot := self fetchPointer: index ofObject: obj. + + ((self isNonImmediate: slot) and: [(self isOldObject: slot) and: [(self isForwarded: slot) not]]) + ifTrue: [(slot >= currentSweepingEntityT and: [(self isMarked: slot) not]) + ifTrue: [self halt. + coInterpreter longPrintOop: (self firstReferenceTo:(self firstReferenceTo: obj)). + self printReferencesTo: (self firstReferenceTo: obj). + self printReferencesTo: obj. + + self printRelativePositionOf: obj. + self printRelativePositionOf: slot. + + coInterpreter longPrintOop: obj. + coInterpreter longPrintOop: slot. + + ^ false]]]]]. + + + ^ true! Item was added: + ----- Method: SpurMemoryManager>>validObjectColorsRelaxed (in category 'debug support') ----- + validObjectColorsRelaxed + + | currentSweepingEntityT | + + currentSweepingEntityT := gc compactor sweeper currentSweepingEntity ifNil: [self firstObject]. + + + self allOldSpaceObjectsFrom: currentSweepingEntityT do: [:obj | + ((self isMarked: obj) and: [(self isPointers: obj )and: [(self classIndexOf: obj) > self lastClassIndexPun and: [(self isWeak: obj) not]]]) + ifTrue: [| slotCount | + slotCount := self numStrongSlotsOfInephemeral: obj. + + 0 to: slotCount - 1 + do: [:index | | slot | + slot := self fetchPointer: index ofObject: obj. + + ((self isNonImmediate: slot) and: [(self isOldObject: slot) and: [(self isForwarded: slot) not]]) + ifTrue: [(slot >= currentSweepingEntityT and: [self isWhite: slot]) + ifTrue: [self halt. + coInterpreter longPrintOop: obj. + coInterpreter longPrintOop: slot. + + ^ false]]]] "right parenthesis expected ->"]. + + + ^ true! Item was added: + SharedPool subclass: #SpurObjStackConstants + instanceVariableNames: '' + classVariableNames: 'ObjStackFixedSlots ObjStackFreex ObjStackNextx ObjStackPageSlots ObjStackTopx' + poolDictionaries: '' + category: 'VMMaker-SpurMemoryManager'! Item was changed: SpurCompactor subclass: #SpurPlanningCompactor instanceVariableNames: 'anomaly biasForGC firstFieldOfRememberedSet firstFreeObject firstMobileObject lastMobileObject mobileStart objectAfterLastMobileObject savedFirstFieldsSpace savedFirstFieldsSpaceNotInOldSpace' classVariableNames: '' poolDictionaries: 'VMBytecodeConstants' + category: 'VMMaker-SpurGarbageCollector'! - category: 'VMMaker-SpurMemoryManager'! + !SpurPlanningCompactor commentStamp: '' prior: 0! - !SpurPlanningCompactor commentStamp: 'eem 6/11/2018 12:43' prior: 0! SpurPlanningCompactor implements the classic planning compaction algorithm for Spur. It uses the fact that there is room for a forwarding pointer in all objects to store the eventual position of an object in the first field. It therefore first locates a large free chunk, or eden or a memory segment, to use as the savedFirstFieldsSpace, which it uses to store the first fields of objects that will be compacted. It then makes at least three passes through the heap. The first pass plans where live movable objects will go, copying their first field to the next slot in savedFirstFieldsSpace, and setting their forwarding pointer to point to their eventual location (see planCompactSavingForwarders). The second pass updates all pointers in live pointer objects to point to objects' final destinations, including the fields in savedFirstFieldsSpace (see updatePointers and updatePointersInMobileObjects). The third pass moves objects to their final positions, unmarking objects, and restoring saved first fields as it does so (see copyAndUnmark: and copyAndUnmarkMobileObjects). If the forwarding fields of live objects in the to-be-moved portion of the entire heap won't fit in savedFirstFieldsSpace, then additional passes can be made until the entire heap has been compacted. When snapshotting multiple passes are made, but when doing a normal GC only one pass is made. Each pass uses a three finger algorithm, a simple extension of the classic two finger algorithm with an extra finger used to identify the lowest pinned object between the to and from fingers. Objects are moved down, starting at the first free object or chunk, provided that they fit below the lowest pinned object above the to finger. When an object won't fit the to finger is moved above the pinned object and the third finger is reset to the next pinned object below the from finger, if any. Instance Variables anomaly <Oop> biasForGC <Boolean> firstFieldOfRememberedSet <Oop> firstFreeObject <Oop> firstMobileObject <Oop> lastMobileObject <Oop> mobileStart <Integer address> objectAfterLastMobileObject <Oop|nil> savedFirstFieldsSpace <SpurContiguousObjStack> savedFirstFieldsSpaceWasAllocated <Boolean> anomaly - if any bogus object is detected by asserts, etc, it is stored in anomaly biasForGC - true if compacting for GC, in which case do only one pass, or false if compacting for snapshot, in which case do as many passes as necessary to compact the entire heap. firstFieldOfRememberedSet - the saved first field of the rememberedSet. The rememberedSet must be relocated specially because it is not a pointer object. And hence the first field needs to be extracted for proper relocation. firstFreeObject - the first free object in a compaction pass. firstMobileObject - the first mobile object in a compaction. Unpinned objects from the firstMobileObject through to the lastMobileObject are implicitly forwarded. lastMobileObject - the last mobile object in a compaction. Unpinned objects from the firstMobileObject through to the lastMobileObject are implicitly forwarded. mobileStart - the address of the first byte in firstFreeObject objectAfterLastMobileObject - the object following the last object that can be moved, used when more than one pass is needed. savedFirstFieldsSpace - the space holding the saved first fields, each overwritten by a forwarding pointer, for the objects from firstMobileObject through to lastMobileObject. savedFirstFieldsSpaceWasAllocated - if true, the memory for savedFirstFieldsSpace was obtained via a call of sqAllocateMemorySegmentOfSize:Above:AllocatedSizeInto:! Item was changed: ----- Method: SpurPlanningCompactor class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator + + super declareCVarsIn: aCCodeGenerator. self declareCAsOop: (self instVarNames select: [:iv| iv endsWith: 'Object']) in: aCCodeGenerator. aCCodeGenerator + var: 'savedFirstFieldsSpace' type: #SpurContiguousObjStack. + + + SpurMemoryManager wantsIncrementalGC + ifTrue: [| incrementalSelectors | + incrementalSelectors := SpurIncrementalCompactor selectors , SpurIncrementalSweeper selectors , SpurIncrementalSweepAndCompact selectors. + + (incrementalSelectors intersection: SpurPlanningCompactor selectors) + do: [:key | + aCCodeGenerator + staticallyResolveMethodNamed: key + forClass: self + to: (self staticallyResolvePolymorphicSelector: key)]] + ! - var: 'savedFirstFieldsSpace' type: #SpurContiguousObjStack! Item was changed: ----- Method: SpurSegmentManager>>findEmptySegNearestInSizeTo: (in category 'growing/shrinking memory') ----- findEmptySegNearestInSizeTo: size | seg best delta | <var: #seg type: #'SpurSegmentInfo *'> <var: #best type: #'SpurSegmentInfo *'> best := nil. delta := size. 0 to: numSegments - 1 do: [:i| seg := self addressOf: (segments at: i). + ((self isEmptySegment: seg) and: [manager gc isOkToDeleteSegment: seg]) ifTrue: - (self isEmptySegment: seg) ifTrue: [best ifNil: [best := seg] ifNotNil: [(size >= (seg segSize * 0.75) and: [(manager cCoerce: seg segSize - size to: #sqInt) abs < delta]) ifTrue: [best := seg. delta := (manager cCoerce: seg segSize - size to: #sqInt) abs]]]]. ^best! Item was added: + ----- Method: SpurSegmentManager>>segmentIndexContainingObj: (in category 'accessing') ----- + segmentIndexContainingObj: objOop + <export: true> + numSegments - 1 to: 0 by: -1 do: + [:i| + objOop >= (segments at: i) segStart ifTrue: + [^i]]. + ^-1! Item was changed: SpurSweeper subclass: #SpurSelectiveCompactor instanceVariableNames: 'segmentToFill lastLilliputianChunk' classVariableNames: 'MaxOccupationForCompaction' poolDictionaries: '' + category: 'VMMaker-SpurGarbageCollector'! - category: 'VMMaker-SpurMemoryManager'! + !SpurSelectiveCompactor commentStamp: '' prior: 0! - !SpurSelectiveCompactor commentStamp: 'cb 10/7/2018 19:54' prior: 0! SpurSelectiveCompactor compacts memory by selecting the memory segments with the most free space and compacting only those, to limit fragmentation while being really quick to perform. The algorithm is fast mostly because it does not update pointers: they are updated lazily during the next marking phase, so there is no need to read the fields of objects in other memory segments that the one compacted. The algorithm works as follow. First, a global sweep pass iterates over the memory linearly, changing unmarked objects to free chunks and concatenating free chunks. During the global sweep phase, the segments of the heap are analysed to determine the percentage of occupation. Second, the least occupied segments are compacted by copying the remaining live objects into an entirely free segment, called regionToFill (we detail later in the paragraph where regionToFill comes from), changing their values to forwarding objects and marking the free chunks as unavailable (removed from free list and marked as data objects). Third, the next marking phase removes all forwarders. Fourth, at the beginning of the next compaction phase the compacted segments from the previous GC can be entirely marked as free space (No need to check anything inside, there were only forwarders and trash data). One of the compacted segment is then selected as the segmentToFill, others are just marked as free chunks. The compaction is effectively partial, compacting only the most critical segments of the heap to limit fragmentation. Compaction time is crazy low, since a low number of objects are moved and pointer updated is lazily done during the next marking phase, while still preventing memory fragmentation. Now this works well when biasForGC is true, but when performing a snapshot, the compactor is just total crap (we need to figure out a solution). segmentToFill <SegInfo> the segment that will be filled through the copying algorithm lastLilliputianChunk <Oop to FreeChunk> This is used as a performance trick for lilliputian free chunks. See below. Segment abuse: The swizzle field of segInfo is abused by using the low 8 bits for occupation and the 9th bit as isBeingCompacted bit. Performance trick for lilliputian chunks: Specific free chunks (called lilliputian, see isLilliputianSize:) are managed using a single linked list instead of a double linked list since there's not enough room in the free chunk for the back pointer. During the sweep phase this is not a problem since we're rebuilding the free chunk structure, but during selective compaction we're detaching free chunks from the free chunk structure and that can be horribly slow (10 seconds sometimes at 20Gb heap due to many iteration over the single linked list). To work around this problem, the sweep phase use lastLilliputianChunk variable to sort the lilliputian free chunk single linked list in ascending address order (See interceptAddFreeChunkWithBytes:at:). During the selective compation phase, the same variable is re-used to iterate at most once over the single linked list while detaching lilliputian chunks (See incrementalUnlinkSmallChunk:). In addition, each segment is annotated during the sweep phase with the last lilliputian chunk it holds. Hence, during the compaction phase, the linked list is iterated but the iteration can jump to the last chunk of the previous segment to compact.! Item was added: + SpurGarbageCollector subclass: #SpurStopTheWorldGarbageCollector + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'VMMaker-SpurGarbageCollector'! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector class>>classesForTranslation (in category 'as yet unclassified') ----- + classesForTranslation + + ^ super classesForTranslation , {SpurMarker . SpurAllAtOnceMarker . SpurPlanningCompactor}! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector class>>compactorClass (in category 'as yet unclassified') ----- + compactorClass + + ^ SpurPlanningCompactor! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector class>>markerClass (in category 'as yet unclassified') ----- + markerClass + + ^ SpurAllAtOnceMarker! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector class>>sourceSortingKey (in category 'as yet unclassified') ----- + sourceSortingKey + "To keep methods in the same order while refactoring..." + ^SpurMemoryManager name! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector>>finishGCPass (in category 'as yet unclassified') ----- + finishGCPass + + "nop in stop the world as we always finish our gc all at once"! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector>>fullGC (in category 'global') ----- + fullGC + "Perform a full eager compacting GC. Answer the size of the largest free chunk." + <returnTypeC: #usqLong> + <inline: #never> "for profiling" + + manager needGCFlag: 0. + manager gcStartUsecs: coInterpreter ioUTCMicrosecondsNow. + manager statMarkCount: 0. + coInterpreter preGCAction: GCModeFull. + self globalGarbageCollect. + coInterpreter postGCAction: GCModeFull. + manager statGCEndUsecs: coInterpreter ioUTCMicrosecondsNow. + manager updateFullGCStats. + ^(manager freeLists at: 0) ~= 0 + ifTrue: [self bytesInBody: manager findLargestFreeChunk] + ifFalse: [0]! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector>>gcForSnapshot (in category 'as yet unclassified') ----- + gcForSnapshot + + self fullGC! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector>>globalGarbageCollect (in category 'as yet unclassified') ----- + globalGarbageCollect + <inline: true> "inline into fullGC" + + manager preGlobalGCActions. + + self assert: self validObjStacks. + self assert: (self isEmptyObjStack: manager markStack). + self assert: (self isEmptyObjStack: manager weaklingStack). + + "Mark objects /before/ scavenging, to empty the rememberedTable of unmarked roots." + self markObjects: true. + manager gcMarkEndUsecs: coInterpreter ioUTCMicrosecondsNow. + + scavenger forgetUnmarkedRememberedObjects. + + coInterpreter setGCMode: GCModeNewSpace. + self doScavenge: MarkOnTenure. + coInterpreter setGCMode: GCModeFull. + + "Mid-way the leak check must be more lenient. Unmarked classes will have been + expunged from the table, but unmarked instances will not yet have been reclaimed." + manager runLeakCheckerFor: GCModeFull + excludeUnmarkedObjs: true + classIndicesShouldBeValid: true. + + manager compactionStartUsecs: coInterpreter ioUTCMicrosecondsNow. + manager segmentManager prepareForGlobalSweep. "for notePinned:" + compactor compact. + manager attemptToShrink. + manager setHeapSizeAtPreviousGC. + + self assert: manager validObjStacks. + self assert: (manager isEmptyObjStack: manager markStack). + self assert: (manager isEmptyObjStack: manager weaklingStack). + self assert: manager allObjectsUnmarked. + manager runLeakCheckerFor: GCModeFull! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector>>incrementalCollect (in category 'global') ----- + incrementalCollect + "not supported in a stop the world GC -> no op" + + <doNotGenerate>! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector>>isOkToDeleteSegment: (in category 'testing') ----- + isOkToDeleteSegment: segment + + <doNotGenerate>! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector>>isStopTheWorld (in category 'testing') ----- + isStopTheWorld + + ^ true! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector>>markObjectsCompletely (in category 'as yet unclassified') ----- + markObjectsCompletely + + "already doing it with markObjects:; just fullfill the interface here" + self markObjects: false! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector>>markObjectsForEnumerationPrimitives (in category 'as yet unclassified') ----- + markObjectsForEnumerationPrimitives + + ^ manager markObjectsForEnumerationPrimitives! Item was added: + ----- Method: SpurStopTheWorldGarbageCollector>>sufficientSpaceAfterGC: (in category 'as yet unclassified') ----- + sufficientSpaceAfterGC: numBytes + + | heapSizePostGC | + self assert: numBytes = 0. + self scavengingGCTenuringIf: TenureByAge. + heapSizePostGC := manager segmentManager totalOldSpaceCapacity - manager totalFreeOldSpace. + (heapSizePostGC - manager heapSizeAtPreviousGC) asFloat / manager heapSizeAtPreviousGC >= manager heapGrowthToSizeGCRatio + ifTrue: [self fullGC] "fullGC will attempt to shrink" + ifFalse: "Also attempt to shrink if there is plenty of free space and no need to GC" + [manager totalFreeOldSpace > (manager shrinkThreshold * 2) ifTrue: + [self attemptToShrink. + ^true]]. + [manager totalFreeOldSpace < manager growHeadroom + and: [(manager growOldSpaceByAtLeast: 0) notNil]] whileTrue: + [manager totalFreeOldSpace >= manager growHeadroom ifTrue: + [^true]]. + manager lowSpaceThreshold > manager totalFreeOldSpace ifTrue: "space is low" + [manager lowSpaceThreshold: 0. "avoid signalling low space twice" + ^false]. + ^true! Item was changed: SpurCompactor subclass: #SpurSweeper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' + category: 'VMMaker-SpurGarbageCollector'! - category: 'VMMaker-SpurMemoryManager'! + !SpurSweeper commentStamp: '' prior: 0! - !SpurSweeper commentStamp: 'cb 4/27/2018 09:43' prior: 0! SpurSweeper is a sweep-only algorithm, setting the compactor to SpurSweeper effectively changes the fullGC to a mark-sweep non-moving algorithm. SpurSweeper is a reference implementation if one wants to evaluate GC performance and compare it to a Mark-Sweep. It's also the only non-moving GC available right now which can be convenient for some experiments. One of the main reason why it was implemented is because advanced compaction algorithm includes a sweep phase (See SelectiveCompactor for example) and SpurSweeper allows to debug the sweep phase separatedly. ! Item was changed: ----- Method: StackInterpreter class>>declareCVarsIn: (in category 'translation') ----- declareCVarsIn: aCCodeGenerator | vmClass | self class == thisContext methodClass ifFalse: [^self]. "Don't duplicate decls in subclasses" vmClass := aCCodeGenerator vmClass. "Generate primitiveTable etc based on vmClass, not just StackInterpreter" aCCodeGenerator addHeaderFile: '<stdio.h> /* for printf */'; addHeaderFile: '<stdlib.h> /* for e.g. alloca */'; addHeaderFile: '<setjmp.h>'; addHeaderFile: '<wchar.h> /* for wint_t */'; + addHeaderFile: '<signal.h>'; addHeaderFile: '"vmCallback.h"'; addHeaderFile: '"sqMemoryFence.h"'; addHeaderFile: '"sqImageFileAccess.h"'; addHeaderFile: '"sqSetjmpShim.h"'; addHeaderFile: '"dispdbg.h"'. LowcodeVM ifTrue: [aCCodeGenerator addHeaderFile: '"sqLowcodeFFI.h"']. vmClass declareInterpreterVersionIn: aCCodeGenerator defaultName: 'Stack'. aCCodeGenerator var: #interpreterProxy type: #'struct VirtualMachine*'. aCCodeGenerator declareVar: #sendTrace type: 'volatile int'; declareVar: #byteCount type: #usqLong. "see dispdbg.h" "These need to be pointers or unsigned." self declareC: #(instructionPointer method newMethod) as: #usqInt in: aCCodeGenerator. "These are all pointers; char * because Slang has no support for C pointer arithmetic." self declareC: #(localIP localSP localFP stackPointer framePointer stackLimit breakSelector) as: #'char *' in: aCCodeGenerator. aCCodeGenerator var: #breakSelectorLength declareC: 'sqInt breakSelectorLength = MinSmallInteger'. self declareC: #(stackPage overflowedPage) as: #'StackPage *' in: aCCodeGenerator. aCCodeGenerator var: #transcript type: #'FILE *'. aCCodeGenerator removeVariable: 'stackPages'. "this is an implicit receiver in the translated code." "This defines bytecodeSetSelector as 0 if MULTIPLEBYTECODESETS is not defined, for the benefit of the interpreter on slow machines." aCCodeGenerator addConstantForBinding: (self bindingOf: #MULTIPLEBYTECODESETS). MULTIPLEBYTECODESETS == false ifTrue: [aCCodeGenerator removeVariable: 'bytecodeSetSelector']. BytecodeSetHasExtensions == false ifTrue: [aCCodeGenerator removeVariable: 'extA'; removeVariable: 'extB']. aCCodeGenerator var: #methodCache declareC: 'sqIntptr_t methodCache[MethodCacheSize + 1 /* ', (MethodCacheSize + 1) printString, ' */]'. NewspeakVM ifTrue: [aCCodeGenerator var: #nsMethodCache declareC: 'sqIntptr_t nsMethodCache[NSMethodCacheSize + 1 /* ', (NSMethodCacheSize + 1) printString, ' */]'] ifFalse: [aCCodeGenerator removeVariable: #nsMethodCache; removeVariable: 'localAbsentReceiver'; removeVariable: 'localAbsentReceiverOrZero']. AtCacheTotalSize isInteger ifTrue: [aCCodeGenerator var: #atCache declareC: 'sqInt atCache[AtCacheTotalSize + 1 /* ', (AtCacheTotalSize + 1) printString, ' */]']. aCCodeGenerator var: #primitiveTable declareC: 'void (*primitiveTable[MaxPrimitiveIndex + 2 /* ', (MaxPrimitiveIndex + 2) printString, ' */])(void) = ', vmClass primitiveTableString. vmClass primitiveTable do: [:symbolOrNot| (symbolOrNot isSymbol and: [symbolOrNot ~~ #primitiveFail]) ifTrue: [(aCCodeGenerator methodNamed: symbolOrNot) ifNotNil: [:tMethod| tMethod returnType: #void]]]. vmClass objectMemoryClass hasSpurMemoryManagerAPI ifTrue: [aCCodeGenerator var: #primitiveAccessorDepthTable type: 'signed char' sizeString: 'MaxPrimitiveIndex + 2 /* ', (MaxPrimitiveIndex + 2) printString, ' */' array: (vmClass primitiveAccessorDepthTableUsing: aCCodeGenerator). aCCodeGenerator removeConstant: #PrimNumberInstVarAt; removeConstant: #PrimNumberPerform; removeConstant: # PrimNumberPerformWithArgs; removeConstant: #PrimNumberShallowCopy; removeConstant: #PrimNumberSlotAt; removeConstant: #PrimNumberFlushExternalPrimitives; removeConstant: #PrimNumberUnloadModule] ifFalse: [aCCodeGenerator removeVariable: #primitiveAccessorDepthTable; removeConstant: #PrimNumberVMParameter]. aCCodeGenerator var: #displayBits type: #'void *'; var: #primitiveCalloutPointer declareC: 'void *primitiveCalloutPointer = (void *)-1'. #('primitiveDoMixedArithmetic' 'upscaleDisplayIfHighDPI' ) do: [:var| aCCodeGenerator var: var declareC: 'sqInt ', var, ' = -1']. self declareC: #(displayWidth displayHeight displayDepth) as: #int in: aCCodeGenerator. aCCodeGenerator var: #primitiveFunctionPointer declareC: 'void (*primitiveFunctionPointer)()'; var: 'pcPreviousToFunction' declareC: 'sqInt (* const pcPreviousToFunction)(sqInt,sqInt) = ', (aCCodeGenerator cFunctionNameFor: PCPreviousToFunction); var: #externalPrimitiveTable declareC: 'void (*externalPrimitiveTable[MaxExternalPrimitiveTableSize + 1 /* ', (MaxExternalPrimitiveTableSize + 1) printString, ' */])(void)'; var: #interruptCheckChain declareC: 'void (*interruptCheckChain)(void) = 0'; var: #showSurfaceFn declareC: 'int (*showSurfaceFn)(sqIntptr_t, int, int, int, int)'. self declareCAsUSqLong: #(nextPollUsecs nextWakeupUsecs "these are high-frequency enough that they're overflowing quite quickly on modern hardware" statProcessSwitch statIOProcessEvents statForceInterruptCheck statCheckForEvents statStackOverflow statStackPageDivorce statIdleUsecs) in: aCCodeGenerator. aCCodeGenerator var: #nextProfileTick type: #sqLong. aCCodeGenerator var: #reenterInterpreter type: 'jmp_buf'. LowcodeVM ifTrue: [aCCodeGenerator var: #lowcodeCalloutState type: #'sqLowcodeCalloutState*'. self declareC: #(nativeSP nativeStackPointer shadowCallStackPointer) as: #'char *' in: aCCodeGenerator] ifFalse: [#(lowcodeCalloutState nativeSP nativeStackPointer shadowCallStackPointer) do: [:var| aCCodeGenerator removeVariable: var]]. (self instVarNames select: [:ivn| ivn beginsWith: 'longRunningPrimitive']) do: [:lrpmVar| aCCodeGenerator var: lrpmVar declareC: '#if LRPCheck\', ((lrpmVar endsWith: 'Usecs') ifTrue: [#usqLong] ifFalse: [#sqInt]), ' ', lrpmVar, '\#endif']! Item was changed: ----- Method: StackInterpreter class>>initializePrimitiveTable (in category 'initialization') ----- (excessive size, no diff calculated) Item was changed: ----- Method: StackInterpreter>>eekcr (in category 'debug printing') ----- eekcr "For marking the end of a leak check print message" <api> <inline: #never> + self print: '\n'; flush. + self cCode: 'raise(SIGINT)' inSmalltalk: [self halt]! - self printf: '\n'. - self cCode: '' inSmalltalk: [self halt]! Item was changed: ----- Method: StackInterpreter>>fireEphemeron: (in category 'finalization') ----- fireEphemeron: ephemeron <option: #SpurObjectMemory> + self cCode: 'raise(SIGINT)'. objectMemory queueMourner: ephemeron; setFormatOf: ephemeron to: objectMemory nonIndexablePointerFormat. self signalFinalization: ephemeron! Item was added: + ----- Method: StackInterpreter>>incremenalMarkAndTraceTraceLog (in category 'object memory support') ----- + incremenalMarkAndTraceTraceLog + "This is a no-op in the StackVM"! Item was added: + ----- Method: StackInterpreter>>incrementalMarkAndTraceInterpreterOops (in category 'object memory support') ----- + incrementalMarkAndTraceInterpreterOops + "Mark and trace all oops in the interpreter's state." + "Assume: All traced variables contain valid oops. + N.B. Don't trace messageSelector and lkupClass; these are ephemeral, live + only during message lookup and because createActualMessageTo will not + cause a GC these cannot change during message lookup." + | oop marker | + + "do not remove. Necessary for resolving polymorphic receiver" + marker := objectMemory marker. + + "Must mark stack pages first to initialize the per-page trace + flags for full garbage collect before any subsequent tracing." + self incrementalMarkAndTraceStackPages. + self incrementalMarkAndTraceTraceLog. + self incrementalMarkAndTracePrimTraceLog. + marker markAndShouldScan: objectMemory specialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes" + (objectMemory isImmediate: newMethod) ifFalse: + [marker markAndShouldScan: newMethod]. + self incrementalTraceProfileState. + tempOop = 0 ifFalse: [marker markAndShouldScan: tempOop]. + tempOop2 = 0 ifFalse: [marker markAndShouldScan: tempOop2]. + + "V3 memory manager support" + 1 to: objectMemory remapBufferCount do: + [:i | + oop := objectMemory remapBuffer at: i. + (objectMemory isImmediate: oop) ifFalse: [marker markAndShouldScan: oop]]! Item was added: + ----- Method: StackInterpreter>>incrementalMarkAndTracePrimTraceLog (in category 'object memory support') ----- + incrementalMarkAndTracePrimTraceLog + "This is a no-op in the StackVM"! Item was added: + ----- Method: StackInterpreter>>incrementalMarkAndTraceStackPage: (in category 'object memory support') ----- + incrementalMarkAndTraceStackPage: thePage + | theSP theFP frameRcvrOffset callerFP oop marker | + <var: #thePage type: #'StackPage *'> + <var: #theSP type: #'char *'> + <var: #theFP type: #'char *'> + <var: #frameRcvrOffset type: #'char *'> + <var: #callerFP type: #'char *'> + <inline: false> + + "do not remove. Necessary for resolving polymorphic receiver" + marker := objectMemory marker. + + self assert: (stackPages isFree: thePage) not. + self assert: (self ifCurrentStackPageHasValidHeadPointers: thePage). + thePage trace: StackPageTraced. + + theSP := thePage headSP. + theFP := thePage headFP. + "Skip the instruction pointer on top of stack of inactive pages." + thePage = stackPage ifFalse: + [theSP := theSP + objectMemory wordSize]. + [frameRcvrOffset := self frameReceiverLocation: theFP. + [theSP <= frameRcvrOffset] whileTrue: + [oop := stackPages longAt: theSP. + (objectMemory isOopForwarded: oop) ifTrue: + [oop := objectMemory followForwarded: oop. + stackPages longAt: theSP put: oop]. + (objectMemory isImmediate: oop) ifFalse: + [marker markAndShouldScan: oop]. + theSP := theSP + objectMemory wordSize]. + (self frameHasContext: theFP) ifTrue: + [self assert: (objectMemory isContext: (self frameContext: theFP)). + marker markAndShouldScan: (self frameContext: theFP)]. + marker markAndShouldScan: (self iframeMethod: theFP). + (callerFP := self frameCallerFP: theFP) ~= 0] whileTrue: + [theSP := theFP + FoxCallerSavedIP + objectMemory wordSize. + theFP := callerFP]. + theSP := theFP + FoxCallerSavedIP. "caller ip is frameCallerContext in a base frame" + [theSP <= thePage baseAddress] whileTrue: + [oop := stackPages longAt: theSP. + (objectMemory isOopForwarded: oop) ifTrue: + [oop := objectMemory followForwarded: oop. + stackPages longAt: theSP put: oop]. + (objectMemory isImmediate: oop) ifFalse: + [marker markAndShouldScan: oop]. + theSP := theSP + objectMemory wordSize]! Item was added: + ----- Method: StackInterpreter>>incrementalMarkAndTraceStackPages (in category 'object memory support') ----- + incrementalMarkAndTraceStackPages + "GC of pages. Throwing away all stack pages on full GC is simple but dangerous + because it causes us to allocate lots of contexts immediately before a GC. + Reclaiming pages whose top context is not referenced is poor because it would + take N incrementalGCs to reclaim N unused pages. Only the page whose top + context is not referred to by the bottom context of any other page would be + reclaimed. Not until the next GC would the page whose top contect is the + previously reclaimed page's base frame's bottom context be reclaimed. + + Better is to not mark stack pages until their contexts are encountered. We can + eagerly trace the active page and the page reachable from its bottom context + if any, and so on. Other pages can be marked when we encounter a married + context." + | thePage | + <inline: false> + 0 to: numStackPages - 1 do: + [:i| + thePage := stackPages stackPageAt: i. + (stackPages isFree: thePage) ifFalse: + [self incrementalMarkAndTraceStackPage: thePage]]. + ^nil! Item was added: + ----- Method: StackInterpreter>>incrementalMarkAndTraceTraceLog (in category 'object memory support') ----- + incrementalMarkAndTraceTraceLog + "This is a no-op in the StackVM"! Item was added: + ----- Method: StackInterpreter>>incrementalTraceProfileState (in category 'object memory support') ----- + incrementalTraceProfileState + + "do not remove. Necessary for resolving polymorphic receiver" + | marker | + marker := objectMemory marker. + + objectMemory hasSpurMemoryManagerAPI ifTrue: + [self followForwardingPointersInProfileState]. + marker pushOnMarkingStackAndMakeGreyIfNecessary: profileProcess. + marker pushOnMarkingStackAndMakeGreyIfNecessary: profileMethod. + marker pushOnMarkingStackAndMakeGreyIfNecessary: profileSemaphore. + + self cppIf: #LRPCheck + ifTrue: + ["The longRunningPrimitiveCheckMethod (LRPCM) is sampled in an interrupt. Be very careful with it. + If longRunningPrimitiveCheckSequenceNumber (LRPCSN) = statCheckForEvents then LRPCM has + been recenty sampled, but it must be newMethod and we don't need to trace it twice. If LRPCSN + ~= statCheckForEvents then LRPCM must be some extant object and needs to be traced." + self sqLowLevelMFence. + (longRunningPrimitiveCheckMethod ~= nil + and: [longRunningPrimitiveCheckSequenceNumber ~= statCheckForEvents]) ifTrue: + [(objectMemory isForwarded: longRunningPrimitiveCheckMethod) ifTrue: + [longRunningPrimitiveCheckMethod := objectMemory followForwarded: longRunningPrimitiveCheckMethod]. + marker pushOnMarkingStackAndMakeGreyIfNecessary: longRunningPrimitiveCheckMethod]. + longRunningPrimitiveCheckSemaphore ~= nil ifTrue: + [(objectMemory isForwarded: longRunningPrimitiveCheckSemaphore) ifTrue: + [longRunningPrimitiveCheckSemaphore := objectMemory followForwarded: longRunningPrimitiveCheckSemaphore]. + marker pushOnMarkingStackAndMakeGreyIfNecessary: longRunningPrimitiveCheckSemaphore]]! Item was added: + ----- Method: StackInterpreterPrimitives>>primitiveGCInfo (in category 'system control primitives') ----- + primitiveGCInfo + "VM parameters are numbered as follows: + 0 stopTheWorld (0) or incremental gc (1) + 1 if incremental gc: current gc phase -> 0 marking; 1 sweeping; 2 compacting + if stopTheWorld -> -1 + 2 eden start + 3 eden limit + 4 freeStart + 5 scavengeThreshold + 6 amount of old space segments + " + + | result staticCount oldSpaceSegmentCount segmentInfoCount | + staticCount := 8. + segmentInfoCount := 5. + oldSpaceSegmentCount := objectMemory numSegments. + result := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: staticCount + (oldSpaceSegmentCount * segmentInfoCount). + + objectMemory storePointerUnchecked: 0 ofObject: result withValue: (objectMemory integerObjectOf: (objectMemory gc isIncremental ifTrue: [1] ifFalse: [0])). + objectMemory storePointerUnchecked: 1 ofObject: result withValue: (objectMemory + integerObjectOf: (objectMemory gc isIncremental + ifTrue: [objectMemory gc phase] + ifFalse: [-1])). + + objectMemory storePointerUnchecked: 2 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory scavenger eden start). + objectMemory storePointerUnchecked: 3 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory scavenger eden limit). + objectMemory storePointerUnchecked: 4 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory freeStart). + objectMemory storePointerUnchecked: 5 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory scavengeThreshold). + objectMemory storePointerUnchecked: 6 ofObject: result withValue: (objectMemory integerObjectOf: objectMemory statSurvivorCount). + + + objectMemory storePointerUnchecked: 7 ofObject: result withValue: (self positiveMachineIntegerFor: oldSpaceSegmentCount). + + 0 to: oldSpaceSegmentCount - 1 + do: [:index | | baseIndex segInfo | + segInfo := self addressOf: (objectMemory segmentManager segments at: index). + baseIndex := staticCount + (index * segmentInfoCount). + + objectMemory storePointerUnchecked: baseIndex ofObject: result withValue: (objectMemory integerObjectOf: segInfo segStart). + objectMemory storePointerUnchecked: baseIndex + 1 ofObject: result withValue: (objectMemory integerObjectOf: segInfo segSize). + objectMemory storePointerUnchecked: baseIndex + 2 ofObject: result withValue: (objectMemory integerObjectOf: (segInfo swizzle bitAnd: 16rFFFF)). + objectMemory storePointerUnchecked: baseIndex + 3 ofObject: result withValue: (objectMemory integerObjectOf: segInfo containsPinned). + objectMemory storePointerUnchecked: baseIndex + 4 ofObject: result withValue: (objectMemory integerObjectOf: (segInfo swizzle bitOr: 1 << 16))]. + + + objectMemory beRootIfOld: result. + self methodReturnValue: result! Item was changed: ----- Method: TMethod>>inlineFunctionCall:in: (in category 'inlining') ----- inlineFunctionCall: aSendNode in: aCodeGen "Answer the body of the called function, substituting the actual parameters for the formal argument variables in the method body. Assume caller has established that: 1. the method arguments are all substitutable nodes, and 2. the method to be inlined contains no additional embedded returns." | sel meth doNotRename argsForInlining substitutionDict | aCodeGen maybeBreakForInlineOf: aSendNode in: self. sel := aSendNode selector. meth := (aCodeGen methodNamed: sel) copy. meth ifNil: [^self inlineBuiltin: aSendNode in: aCodeGen]. doNotRename := Set withAll: args. argsForInlining := aSendNode argumentsForInliningCodeGenerator: aCodeGen. + [meth args with: argsForInlining do: - meth args with: argsForInlining do: [ :argName :exprNode | exprNode isLeaf ifTrue: + [doNotRename add: argName]]] + on: Error + do: [:ex | ex messageText = 'Other collection must be the same size' + ifTrue: [ | errorMessage | + errorMessage := 'In ' , self definingClass name, '>>' , self selector. + errorMessage := errorMessage , ' for method ' , meth definingClass name, '>>' , meth selector. + errorMessage := errorMessage , ' following args where expected {' , (argsForInlining joinSeparatedBy: ', ') , '}'. + errorMessage := errorMessage , ' but got {' , (meth args joinSeparatedBy: ', ') , '}'. + "the errorMessage is probably extremenly long and not that easy to read in the header of the Debugger + window. => print it on the transcript for better readability (as multiline strings in window titles seem + not to be supported :( " + Transcript showln: errorMessage. + + self error: errorMessage] + ifFalse: [ex signal]]. - [doNotRename add: argName]]. (meth statements size = 2 and: [meth statements first isSend and: [meth statements first selector == #flag:]]) ifTrue: [meth statements removeFirst]. meth renameVarsForInliningInto: self except: doNotRename in: aCodeGen. meth renameLabelsForInliningInto: self. self addVarsDeclarationsAndLabelsOf: meth except: doNotRename. substitutionDict := Dictionary new: meth args size * 2. meth args with: argsForInlining do: [ :argName :exprNode | (exprNode isVariable and: [exprNode name = argName]) ifFalse: [substitutionDict at: argName put: exprNode]. (doNotRename includes: argName) ifFalse: [locals remove: argName]]. meth parseTree bindVariablesIn: substitutionDict. ^meth parseTree endsWithReturn ifTrue: [meth parseTree copyWithoutReturn] ifFalse: [meth parseTree]! Item was changed: ----- Method: TMethod>>prepareMethodIn: (in category 'transformations') ----- prepareMethodIn: aCodeGen "Record sends of builtin operators, map sends of the special selector dispatchOn:in: with case statement nodes, and map sends of caseOf:[otherwise:] to switch statements. Declare limit variables for to:[by:]do: loops with limits that potentially have side-effects. As a hack also update the types of variables introduced to implement cascades correctly. This has to be done at the same time as this is done, so why not piggy back here?" aCodeGen maybeBreakForTestToInline: selector in: self. extraVariableNumber ifNotNil: [declarations keysAndValuesDo: [:varName :decl| decl isBlock ifTrue: [self assert: ((varName beginsWith: 'cascade') and: [varName last isDigit]). locals add: varName. self declarationAt: varName put: (decl value: self value: aCodeGen), ' ', varName]]]. aCodeGen pushScope: declarations while:"N.B. nodesWithParentsDo: is bottom-up, hence replacement is destructive and conserved." [parseTree nodesWithParentsDo: [:node :parent| node isSend ifTrue: + [aCodeGen ifStaticallyResolvedPolymorphicReceiverThenUpdateSelectorIn: node fromMethodIn: self definingClass. - [aCodeGen ifStaticallyResolvedPolymorphicReceiverThenUpdateSelectorIn: node. (aCodeGen isBuiltinSelector: node selector) ifTrue: [node isBuiltinOperator: true. "If a to:by:do:'s limit has side-effects, declare the limit variable, otherwise delete it from the args" node selector = #to:by:do: ifTrue: [self ensureToByDoLoopLimitIsSafeAndEfficient: node in: aCodeGen]] ifFalse: [(aCodeGen isStackAccessor: node selector) ifTrue: "compute and cache the accessor depth early, before inlining destroys the accessor chains" [self export ifTrue: [aCodeGen accessorDepthForMethod: self]] ifFalse: [(CaseStatements includes: node selector) ifTrue: [parent replaceNodesIn: (Dictionary newFromPairs: { node. self buildCaseStmt: node in: aCodeGen})]. (#(caseOf: #caseOf:otherwise:) includes: node selector) ifTrue: [parent replaceNodesIn: (Dictionary newFromPairs: { node. self buildSwitchStmt: node parent: parent })]. (#(printf: fprintf: f:printf: f:wprintf:) includes: node selector) ifTrue: [self transformPrintf: node in: aCodeGen]. (node receiver isVariable and: [node receiver name = #Character and: [node selector isUnary]]) ifTrue: [parent replaceNodesIn: (Dictionary newFromPairs: { node. TConstantNode new setValue: (Character perform: node selector) })]]]]]]! Item was changed: SharedPool subclass: #VMBasicConstants instanceVariableNames: '' + classVariableNames: 'BaseHeaderSize BytecodeSetHasExtensions BytesPerOop BytesPerWord COGMTVM COGVM CloneOnGC CloneOnScavenge DisownVMForFFICall DisownVMForThreading DoAssertionChecks DoExpensiveAssertionChecks FastCPrimitiveAlignForFloatsFlag FastCPrimitiveFlag GCCheckFreeSpace GCCheckImageSegment GCCheckPrimCall GCCheckShorten GCModeBecome GCModeFull GCModeIncremental GCModeNewSpace HashMultiplyConstant HashMultiplyMask IMMUTABILITY LowcodeVM MULTIPLEBYTECODESETS MarkStackRecord NewspeakVM PharoVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrCallbackError PrimErrFFIException PrimErrFFIMarshallingError PrimErrGenericFailure PrimErrInappropriate PrimErrInternalError PrimErrLimitExceeded PrimErrNamedInternal PrimErrNeedCompaction PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrOSError PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrObjectMoved PrimErrObjectNotPinned PrimErrOperationFailed PrimErrUnin itialized PrimErrUnsupported PrimErrWritePastObject PrimNoErr PrimNumberHandlerMarker PrimNumberNoContextSwitchMarker PrimNumberUnwindMarker SPURVM STACKVM SistaVM TempVectReadBarrier VMBIGENDIAN' - classVariableNames: 'BaseHeaderSize BytecodeSetHasExtensions BytesPerOop BytesPerWord COGMTVM COGVM CloneOnGC CloneOnScavenge DisownVMForFFICall DisownVMForThreading DoAssertionChecks DoExpensiveAssertionChecks FastCPrimitiveAlignForFloatsFlag FastCPrimitiveFlag GCCheckFreeSpace GCCheckImageSegment GCCheckPrimCall GCCheckShorten GCModeBecome GCModeFull GCModeIncremental GCModeNewSpace HashMultiplyConstant HashMultiplyMask IMMUTABILITY LowcodeVM MULTIPLEBYTECODESETS NewspeakVM PharoVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrCallbackError PrimErrFFIException PrimErrFFIMarshallingError PrimErrGenericFailure PrimErrInappropriate PrimErrInternalError PrimErrLimitExceeded PrimErrNamedInternal PrimErrNeedCompaction PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrOSError PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrObjectMoved PrimErrObjectNotPinned PrimErrOperationFailed PrimErrUninitialized PrimEr rUnsupported PrimErrWritePastObject PrimNoErr PrimNumberHandlerMarker PrimNumberNoContextSwitchMarker PrimNumberUnwindMarker SPURVM STACKVM SistaVM TempVectReadBarrier VMBIGENDIAN' poolDictionaries: '' category: 'VMMaker-Interpreter'! !VMBasicConstants commentStamp: '<historical>' prior: 0! I am a shared pool for basic constants upon which the VM as a whole depends. self ensureClassPool. self classPool declare: #BytesPerWord from: VMSqueakV3ObjectRepresentationConstants classPool. self classPool declare: #BaseHeaderSize from: VMSqueakV3ObjectRepresentationConstants classPool (ObjectMemory classPool keys select: [:k| k beginsWith: 'Byte']) do: [:k| self classPool declare: k from: ObjectMemory classPool]! Item was added: + ----- Method: VMClass class>>hasPolymorphicSelectors (in category 'translation') ----- + hasPolymorphicSelectors + "when overwritten to true the code generator will try to resolve calls to 'self' as a polymorphic call. You probably want + to overwrite staticallyResolvePolymorphicSelector: (example SpurMarker) to only resolve methods that are polymorphic." + + ^ false!

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev November 2022