Vm-dev August 2022

vm-dev@lists.squeakfoundation.org

11 participants
75 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] 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

[OpenSmalltalk/opensmalltalk-vm] Document VM release process (Issue #637)
by Marcel Taeumel 05 Nov '22

05 Nov '22

Here is a draft. ----------- How to make a new RC of the OSVM: 1. Tag specific commit with its UTC timestamp, e.g., 202205110711 for May 11, 2022 at 7:11 2. Run all "Build for*" workflows manually for that tag 3. Verify that a pre-release was created for that tag, containing all build artifacts How to make a new release of the OSVM: 1. Do a new RC (see above) 2. Edit that GitHub pre-release to be an actual release 3. Change the description to have some release notes on the changes How to make use of OSVM-RC in squeak-app bundles: 1. Maybe do a new RC (see above) 2. In any branch's bundle.yml, set VM_RC_TAG in prepare-bundles job to the RC tag How to make use of a new OSVM release in squeak-app bundles: 1. Maybe make a new VM release (see above) 2. Update the files in http://files.squeak.org/base/ for the Squeak versions of your choice 3. :warning: Watch out for minor differences between OSVM packaging and what vm-*.zip expects. For example, Linux has an extra indirection that needs to be removed. And those macOS .dmg packages have to be converted to .zip for squeak-app. -- Reply to this email directly or view it on GitHub: https://github.com/OpenSmalltalk/opensmalltalk-vm/issues/637 You are receiving this because you are subscribed to this thread. Message ID: <OpenSmalltalk/opensmalltalk-vm/issues/637(a)github.com>

2 1

[OpenSmalltalk/opensmalltalk-vm] Memory leak (Issue #642)
by smalltalking 11 Oct '22

11 Oct '22

I noticed that recent VMs leak a few hundred kilobytes of memory every 3-6 seconds. It happens even if you just start VM and do nothing with the image. I tested it with various 64-bit Linux VMs. There seems to be no upper limit on the leaked memory. The leak happens even with the -memory option set. The size of the object memory is not affected by the leak, saved images remain small and the image does not see the increase in memory usage. Affected VMs include: 5.0-202206021410, 5.0-202205110711, 5.0-202204190959 Unaffected VMs include: 5.0-202112022203 and 5.0-202112201228 The 5.0-202206021410 assert and debug VMs leak the memory as well. -- Reply to this email directly or view it on GitHub: https://github.com/OpenSmalltalk/opensmalltalk-vm/issues/642 You are receiving this because you are subscribed to this thread. Message ID: <OpenSmalltalk/opensmalltalk-vm/issues/642(a)github.com>

7 18

[OpenSmalltalk/opensmalltalk-vm] macOS --metal backwards compatibility regarding primitives 126, 127, 231 (Issue #627)
by Marcel Taeumel 11 Oct '22

11 Oct '22

As of https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/2d7105db755928fd90…, there can be flickering or invisible Morphic dragging if no image-side composition buffer is used. In Squeak, that composition buffer is either already used or can be activated for older images by hand via: ```Smalltalk PasteUpMorph disableDeferredUpdates: true. Project allMorphicProjects do: [:ea | ea world canvas: nil]. ``` Also see: - http://lists.squeakfoundation.org/pipermail/vm-dev/2022-April/037907.html - http://lists.squeakfoundation.org/pipermail/vm-dev/2022-April/037888.html - http://lists.squeakfoundation.org/pipermail/vm-dev/2022-April/037891.html - http://lists.squeakfoundation.org/pipermail/vm-dev/2022-April/037897.html For the macOS `--metal` backend, one might actually implement that extra video buffer here: https://github.com/OpenSmalltalk/opensmalltalk-vm/blob/2d7105db755928fd9082… And then read from that buffer and **not** the `displayBits` here: https://github.com/OpenSmalltalk/opensmalltalk-vm/blob/2d7105db755928fd9082… ...but **only if** the `deferDisplayUpdates` flag is `false` again. **NOTE THAT** the old approach to always commit content from `displayBits` to the graphics backend entailed a *serious performance regression* as it slows down the interpreter loop to a maximum of 60 FPS, regardless of other stuff waiting in the image side. That is, primitives 127 and 231 were awfully slow and blocking on macOS. At least that got better in https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/2d7105db755928fd90… ------------- Another, more flexible, approach would be to fix **primitive 126** to actually *fail* if a certain graphics backend does not support deferred updates. This might work if platform-specific code would be able to let that primitive fail. See: - `StackInterpreterPrimitives >> primitiveDeferDisplayUpdates` in VMMaker This would work for recent versions of Cuis. However, the existing code in older Squeak images did not correctly invalidate the canvas and thus was not even able to flip between image-side and vm-side composition buffer for different results of primitive 126. Thus, such a fix would also only work from here on for future versions of Squeak and Cuis. -- Reply to this email directly or view it on GitHub: https://github.com/OpenSmalltalk/opensmalltalk-vm/issues/627 You are receiving this because you are subscribed to this thread. Message ID: <OpenSmalltalk/opensmalltalk-vm/issues/627(a)github.com>

6 16

[ANN] OpenSmalltalk VM 2022 released (tag 202205110711)
by Marcel Taeumel 15 Sep '22

15 Sep '22

Hi all! We just released the next version of the OpenSmalltalk VM. Please find the binaries here: https://github.com/OpenSmalltalk/opensmalltalk-vm/releases/tag/202205110711 [https://github.com/OpenSmalltalk/opensmalltalk-vm/releases/tag/202205110711] (see VMMaker.oscog-mt.3184 and update.oscog-mt.6.mcm) That version will be used in the upcoming Squeak 6.0 and also updated bundles for Squeak 5.3. And probably in upcoming Cuis releases. :-) Here is an attempt of a change log (since 2020): - Adds ARMv8/Aarch64/ARM64 JIT incl. support for Apple M1 - Adds "fast C primitives" via #FastCPrimitiveFlag - Adds support for catching exceptions in FFI callouts - Adds #primitiveScreenScaleFactor (for DPI-aware images) - Adds primitives 568 and 578 complementing 88 (primitiveSuspend) - Adds #primitiveMultipleBytecodeSetsActive to update image format for SistaV1 - Adds VectorEnginePlugin - Fixes regressions in ARMv6 support - Fixes performance regressions of -metal and -opengl backends on macOS - Fixes -core-graphics backend on macOS - Fixes Retina scaling on macOS, i.e., support "backing scale factor" - Fixes primitive 126 to fail on graphics backends w/o composition buffer - Fixes regressions in vm-display-fbdev on Linux - Fixes time sync (e.g., for DST) on Windows - Fixes UDP binding on Windows I am sure that I forgot something especially in plugin code. Please expand on this. BIG THANKS to everybody who has worked on this release! Personally, I would like to thank Eliot, who is a great software architect who keeps on making the OSVM faster with every commit. Thank you! Best, Marcel (on behalf of the OSVM core dev team)

5 6

[OpenSmalltalk/opensmalltalk-vm] VM crash (probably wrong forward pointer calculation) (Issue #614)
by unique75m 07 Sep '22

07 Sep '22

This I what I get in the VS2022 debugger. Of course, at the moment I do not understand the code there, but maybe hopefully Eliot can see something interesting in it. I leave VS open and look tomorrow at the code, maybe I understand a bit of it :-) Seems there is something wrong with the forward pointers. I assume the longAt(referent) fails? I guess it is a macro, but VS could not find the definition. ########## Code area - the --> line is failing with access violation ########### /* begin literalCountOfMethodHeader: */ assert((((header) & 7) == 1)); numLiterals = ((header >> 3)) & AlternateHeaderNumLiteralsMask; numSlots = numLiterals + LiteralStart; l9: /* end numStrongSlotsOf:format:ephemeronInactiveIf: */; for (i = 0; i < numSlots; i += 1) { referent = longAt((referrer + BaseHeaderSize) + (((sqInt)((usqInt)(i) << (shiftForWord()))))); if ((!(referent & (tagMask())))) { /* a forwarding pointer could be because of become: or scavenging. */ --> if ((!((longAt(referent)) & ((classIndexMask()) - (isForwardedObjectClassIndexPun()))))) { /* begin followForwarded: */ assert(isUnambiguouslyForwarder(referent)); /* begin fetchPointer:ofMaybeForwardedObject: */ referent1 = longAt((referent + BaseHeaderSize) + (0U << (shiftForWord()))); while (((!(referent1 & (tagMask())))) && ((!((longAt(referent1)) & ((classIndexMask()) - (isForwardedObjectClassIndexPun())))))) { /* begin fetchPointer:ofMaybeForwardedObject: */ referent1 = longAt((referent1 + BaseHeaderSize) + (0U << (shiftForWord()))); } referent = referent1; ########## Call stack ############ Squeak.exe!scavengeReferentsOf(__int64 referrer) Zeile 42680 unter C:\Users\joerg\Persoenlich\Entwicklung\Squeak\vmssource\trunk\src\spur64.cog\cointerp.c (42680) Squeak.exe!scavengeRememberedSetStartingAt(__int64 n) Zeile 42760 unter C:\Users\joerg\Persoenlich\Entwicklung\Squeak\vmssource\trunk\src\spur64.cog\cointerp.c (42760) Squeak.exe!scavengeLoop() Zeile 42542 unter C:\Users\joerg\Persoenlich\Entwicklung\Squeak\vmssource\trunk\src\spur64.cog\cointerp.c (42542) Squeak.exe!doScavenge(__int64 tenuringCriterion) Zeile 47599 unter C:\Users\joerg\Persoenlich\Entwicklung\Squeak\vmssource\trunk\src\spur64.cog\cointerp.c (47599) Squeak.exe!scavengingGCTenuringIf(__int64 tenuringCriterion) Zeile 57959 unter C:\Users\joerg\Persoenlich\Entwicklung\Squeak\vmssource\trunk\src\spur64.cog\cointerp.c (57959) Squeak.exe!sufficientSpaceAfterGC(__int64 numBytes) Zeile 58691 unter C:\Users\joerg\Persoenlich\Entwicklung\Squeak\vmssource\trunk\src\spur64.cog\cointerp.c (58691) Squeak.exe!checkForEventsMayContextSwitch(__int64 mayContextSwitch) Zeile 62762 unter C:\Users\joerg\Persoenlich\Entwicklung\Squeak\vmssource\trunk\src\spur64.cog\cointerp.c (62762) Squeak.exe!handleStackOverflowOrEventAllowContextSwitch(__int64 mayContextSwitch) Zeile 66037 unter C:\Users\joerg\Persoenlich\Entwicklung\Squeak\vmssource\trunk\src\spur64.cog\cointerp.c (66037) Squeak.exe!ceStackOverflow(__int64 contextSwitchIfNotNil) Zeile 15593 unter C:\Users\joerg\Persoenlich\Entwicklung\Squeak\vmssource\trunk\src\spur64.cog\cointerp.c (15593) [Externer Code] Squeak.exe!ioInitHeartbeat() Zeile 420 unter C:\Users\joerg\Persoenlich\Entwicklung\Squeak\vmssource\trunk\platforms\win32\vm\sqWin32Heartbeat.c (420) Squeak.exe!interpret() Zeile 2875 unter C:\Users\joerg\Persoenlich\Entwicklung\Squeak\vmssource\trunk\src\spur64.cog\cointerp.c (2875) Squeak.exe!sqMain(int argc, char * * argv) Zeile 1761 unter C:\Users\joerg\Persoenlich\Entwicklung\Squeak\vmssource\trunk\platforms\win32\vm\sqWin32Main.c (1761) Squeak.exe!WinMain(HINSTANCE__ * hInst, HINSTANCE__ * hPrevInstance, char * lpCmdLine, int nCmdShow) Zeile 1851 unter C:\Users\joerg\Persoenlich\Entwicklung\Squeak\vmssource\trunk\platforms\win32\vm\sqWin32Main.c (1851) [Externer Code] ########## Locals ############ classFormat 662660168776 __int64 contextSize 72198296718755736 __int64 fmt 2 __int64 foundNewReferentOrIsWeakling 0 __int64 header 140698790658008 __int64 header1 140698758633160 __int64 i 37029628 __int64 newLocation 811789632 __int64 numLiterals 64 __int64 numSlots 167772160 __int64 numSlots1 255 unsigned __int64 numSlots2 167772160 unsigned __int64 objOop1 72057594139401638 __int64 referent 139599658561184 __int64 referent1 0 __int64 referrer 140700938141704 __int64 sp 72058702004626295 __int64 ############## Second try ################## I needed to restart it again, here are my new local values in debugger classFormat 973468582328 __int64 contextSize 72198310804720808 __int64 fmt 2 __int64 foundNewReferentOrIsWeakling 0 __int64 header 140699864399832 __int64 header1 140698758633160 __int64 i 81749860 __int64 newLocation 2070121416 __int64 numLiterals 64 __int64 numSlots 335544320 __int64 numSlots1 255 unsigned __int64 numSlots2 335544320 unsigned __int64 objOop1 72057594296693111 __int64 referent 139620721982368 __int64 referent1 0 __int64 referrer 140711869546504 __int64 sp 72058702004626295 __int64 numSlots seems to me very wrong. If I do some calculations I get also not the same value that the debugger says me. Here is the code numLiterals = ((header >> 3)) & AlternateHeaderNumLiteralsMask; numSlots = numLiterals + LiteralStart; AlternateHeaderNumLiteralsMask seems to be 0x7fff LiteralStart seems to be 1 For me is: numLiterals = ((140699864399832 >> 3)) & 0x7fff = 32763 —> does not match the debugger local, where is the 64 coming from Seems to me somebody has overridden already the „header“ variable, which seems to be wrong. Could it be that some other thread is writing in the wrong memory area and override my values? Jörg ########## System Information ############## Gerätename timemachine Prozessor AMD Ryzen 9 3900X 12-Core Processor 3.80 GHz Installierter RAM 32,0 GB Geräte-ID F6FA897B-DDB1-44D6-9BF3-8BD1110AA754 Produkt-ID 00326-10048-08575-AA867 Systemtyp 64-Bit-Betriebssystem, x64-basierter Prozessor Stift- und Toucheingabe Für diese Anzeige ist keine Stift- oder Toucheingabe verfügbar. Edition Windows 10 Home Version 20H2 Installiert am ‎23.‎03.‎2021 Betriebssystembuild 19042.1526 Leistung Windows Feature Experience Pack 120.2212.4170.0 Visual Studio 2022 win64x64\squeak.cog.spur VM version ??? I ask Eliot how i can see that on my current local github clone and post it later ############# Code for reproducation ############## Simply execute the following Smalltalk code. Maybe you need to run it multiple times, for me the crash happens sometimes at the 3rd or 4th try. | oc | oc := OrderedCollection new. 400000000 timesRepeat: [oc add: Object new] -- Reply to this email directly or view it on GitHub: https://github.com/OpenSmalltalk/opensmalltalk-vm/issues/614 You are receiving this because you are subscribed to this thread. Message ID: <OpenSmalltalk/opensmalltalk-vm/issues/614(a)github.com>

1 4

VM Maker: VMMaker.oscog.seperateMarking-WoC.3256.mcz
by commits＠source.squeak.org 01 Sep '22

01 Sep '22

Tom Braun uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog.seperateMarking-WoC.3256.mcz ==================== Summary ==================== Name: VMMaker.oscog.seperateMarking-WoC.3256 Author: WoC Time: 31 August 2022, 4:25:24.728984 pm UUID: 1e46fa16-0827-45d5-8ee0-4e5c2515b517 Ancestors: VMMaker.oscog.seperateMarking-WoC.3255, VMMaker.oscog-nice.3251 runnable stack vm (that runs for some time until it crashes) fixed various bugs: - ignored BitArrays in the write barrier - renamed initilize... to init methods to avoid Slang mischief - replaced fullGC by running incremental GC often (will be changed later on) - hide reserved segment from other Memory manager parts and fix leak checker to take this into account (some changes from pulling the newest VMMaker version in BitBltSimulation, SocketPlugin and CCodeGenerator) =============== Diff against VMMaker.oscog.seperateMarking-WoC.3255 =============== Item was changed: ----- Method: BitBltSimulation>>alphaBlendConst:with:paintMode: (in category 'combination rules') ----- alphaBlendConst: sourceWord with: destinationWord paintMode: paintMode "Blend sourceWord with destinationWord using a constant alpha. Alpha is encoded as 0 meaning 0.0, and 255 meaning 1.0. The blend produced is alpha*source + (1.0-alpha)*dest, with the computation being performed independently on each color component. This function could eventually blend into any depth destination, using the same color averaging and mapping as warpBlt. paintMode = true means do nothing if the source pixel value is zero." "This first implementation works with dest depths of 16 and 32 bits only. Normal color mapping will allow sources of lower depths in this case, and results can be mapped directly by truncation, so no extra color maps are needed. To allow storing into any depth will require subsequent addition of two other colormaps, as is the case with WarpBlt." | pixMask destShifted sourceShifted destPixVal rgbMask sourcePixVal unAlpha result pixBlend shift blend maskShifted bitsPerColor blendAG blendRB | <inline: false> <returnTypeC: 'unsigned int'> <var: 'sourceWord' type: #'unsigned int'> <var: 'destinationWord' type: #'unsigned int'> <var: 'blendRB' type: #'unsigned int'> <var: 'blendAG' type: #'unsigned int'> <var: 'result' type: #'unsigned int'> <var: 'sourceAlpha' type: #'unsigned int'> <var: 'unAlpha' type: #'unsigned int'> <var: 'sourceShifted' type: #'unsigned int'> <var: 'destShifted' type: #'unsigned int'> <var: 'maskShifted' type: #'unsigned int'> <var: 'pixMask' type: #'unsigned int'> <var: 'rgbMask' type: #'unsigned int'> <var: 'pixBlend' type: #'unsigned int'> <var: 'blend' type: #'unsigned int'> destDepth < 16 ifTrue: [^ destinationWord "no-op"]. unAlpha := 255 - sourceAlpha. result := destinationWord. destPPW = 1 ifTrue:["32bpp blends include alpha" paintMode & (sourceWord = 0) "painting a transparent pixel" ifFalse:[ blendRB := ((sourceWord bitAnd: 16rFF00FF) * sourceAlpha) + + ((destinationWord bitAnd: 16rFF00FF) * unAlpha) + 16r800080. "blend red and blue" - ((destinationWord bitAnd: 16rFF00FF) * unAlpha) + 16rFF00FF. "blendRB red and blue" blendAG := ((sourceWord>> 8 bitAnd: 16rFF00FF) * sourceAlpha) + + ((destinationWord>>8 bitAnd: 16rFF00FF) * unAlpha) + 16r800080. "blend alpha and green" - ((destinationWord>>8 bitAnd: 16rFF00FF) * unAlpha) + 16rFF00FF. "blendRB alpha and green" + blendRB := (blendRB >> 8 bitAnd: 16rFF00FF) + blendRB >> 8 bitAnd: 16rFF00FF. "divide by 255" + blendAG := (blendAG >> 8 bitAnd: 16rFF00FF) + blendAG >> 8 bitAnd: 16rFF00FF. - blendRB := blendRB + (blendRB - 16r10001 >> 8 bitAnd: 16rFF00FF) >> 8 bitAnd: 16rFF00FF. "divide by 255" - blendAG := blendAG + (blendAG - 16r10001 >> 8 bitAnd: 16rFF00FF) >> 8 bitAnd: 16rFF00FF. result := blendRB bitOr: blendAG<<8. ]. ] ifFalse:[ pixMask := maskTable at: destDepth. bitsPerColor := 5. rgbMask := 16r1F. maskShifted := destMask. destShifted := destinationWord. sourceShifted := sourceWord. 1 to: destPPW do:[:j | sourcePixVal := sourceShifted bitAnd: pixMask. ((maskShifted bitAnd: pixMask) = 0 "no effect if outside of dest rectangle" or: [paintMode & (sourcePixVal = 0) "or painting a transparent pixel"]) ifFalse: [destPixVal := destShifted bitAnd: pixMask. pixBlend := 0. 1 to: 3 do: [:i | shift := (i-1)*bitsPerColor. blend := (((sourcePixVal>>shift bitAnd: rgbMask) * sourceAlpha) + ((destPixVal>>shift bitAnd: rgbMask) * unAlpha)) + + 128. "+128 for rounding" + blend := blend >> 8 + blend >> 8 bitAnd: rgbMask. "divide by 255" - + 254 // 255 bitAnd: rgbMask. pixBlend := pixBlend bitOr: blend<<shift]. result := (result bitAnd: (pixMask << (j-1*16)) bitInvert32) bitOr: pixBlend << (j-1*16)]. maskShifted := maskShifted >> destDepth. sourceShifted := sourceShifted >> destDepth. destShifted := destShifted >> destDepth]. ]. ^ result ! Item was changed: ----- Method: BitBltSimulation>>alphaBlendScaled:with: (in category 'combination rules') ----- alphaBlendScaled: sourceWord with: destinationWord "Blend sourceWord with destinationWord using the alpha value from sourceWord. Alpha is encoded as 0 meaning 0.0, and 255 meaning 1.0. In contrast to alphaBlend:with: the color produced is srcColor + (1-srcAlpha) * dstColor e.g., it is assumed that the source color is already scaled." <returnTypeC: #'unsigned int'> <inline: false> "Do NOT inline this into optimized loops" | unAlpha rb ag | <var: 'sourceWord' type: #'unsigned int'> <var: 'destinationWord' type: #'unsigned int'> <var: 'rb' type: #'unsigned int'> <var: 'ag' type: #'unsigned int'> <var: 'unAlpha' type: #'unsigned int'> unAlpha := 255 - (sourceWord >> 24). "High 8 bits of source pixel is source opacity (ARGB format)" + rb := (destinationWord bitAnd: 16rFF00FF) * unAlpha + 16r800080. "add 16r80 for rounding division to nearest byte" + ag := (destinationWord >> 8 bitAnd: 16rFF00FF) * unAlpha + 16r800080. "add 16r80 for rounding division to nearest byte" + rb := (rb >> 8 bitAnd: 16rFF00FF) + rb >> 8. "divide by 255" + ag := (ag >> 8 bitAnd: 16rFF00FF) + ag >> 8. "divide by 255" + rb := (rb bitAnd: 16rFF00FF) + (sourceWord bitAnd: 16rFF00FF). "blend red and blue components" + ag := (ag bitAnd: 16rFF00FF) + (sourceWord >> 8 bitAnd: 16rFF00FF). "blend alpha and green components" - rb := ((destinationWord bitAnd: 16rFF00FF) * unAlpha >> 8 bitAnd: 16rFF00FF) + (sourceWord bitAnd: 16rFF00FF). "blend red and blue components" - ag := ((destinationWord >> 8 bitAnd: 16rFF00FF) * unAlpha >> 8 bitAnd: 16rFF00FF) + (sourceWord >> 8 bitAnd: 16rFF00FF). "blend alpha and green components" rb := (rb bitAnd: 16rFF00FF) bitOr: (rb bitAnd: 16r01000100) * 16rFF >> 8. "saturate red and blue components if there is a carry" ag := (ag bitAnd: 16rFF00FF) << 8 bitOr: (ag bitAnd: 16r01000100) * 16rFF. "saturate alpha and green components if there is a carry" ^ag bitOr: rb "recompose"! Item was changed: ----- Method: BitBltSimulation>>alphaBlendUnscaled:with: (in category 'combination rules') ----- alphaBlendUnscaled: sourceWord with: destinationWord "Blend sourceWord with destinationWord using the alpha value from both sourceWord and destinationWord. Alpha is encoded as 0 meaning 0.0, and 255 meaning 1.0. The alpha channel and color produced are srcAlpha + (destAlpha*(1-srcAlpha)) (srcAlpha*srcColor + (destAlpha*(1-srcAlpha)*dstColor)) / (srcAlpha + (destAlpha*(1-srcAlpha))) In contrast to alphaBlend:with: the method does not assume that destination form is opaque. In contrast to alphaBlendScaled:with: the method does not assume that colors have been pre-scaled (muliplied) by alpha channel." | alpha blendA result blendR blendB blendG | <inline: false> <returnTypeC: 'unsigned int'> <var: 'sourceWord' type: #'unsigned int'> <var: 'destinationWord' type: #'unsigned int'> <var: 'blendA' type: #'unsigned int'> <var: 'blendR' type: #'unsigned int'> <var: 'blendG' type: #'unsigned int'> <var: 'blendB' type: #'unsigned int'> <var: 'result' type: #'unsigned int'> <var: 'alpha' type: #'unsigned int'> alpha := sourceWord >> 24. "High 8 bits of source pixel, assuming ARGB encoding" alpha = 0 ifTrue: [ ^ destinationWord ]. alpha = 255 ifTrue: [ ^ sourceWord ]. blendA := 16rFF * alpha + (16rFF - alpha * (destinationWord >> 24)) + 16r80. "blend alpha channels" + blendA := blendA >> 8 + blendA >> 8 bitAnd: 16rFF. "divide by 255" - blendA := blendA + (blendA - 1 >> 8 bitAnd: 16rFF) >> 8 bitAnd: 16rFF. "divide by 255" blendR := ((sourceWord bitAnd: 16rFF0000) * alpha) + ((destinationWord bitAnd: 16rFF0000) * (blendA-alpha)) +(blendA<<15) // blendA bitAnd: 16rFF0000. "blend red" blendG := ((sourceWord bitAnd: 16r00FF00) * alpha) + ((destinationWord bitAnd: 16r00FF00) * (blendA-alpha)) +(blendA<<7) // blendA bitAnd: 16r00FF00. "blend green" blendB := ((sourceWord bitAnd: 16r0000FF) * alpha) + ((destinationWord bitAnd: 16r0000FF) * (blendA-alpha)) +(blendA>>1) // blendA bitAnd: 16r0000FF. "blend blue" result := ((blendR bitOr: blendB) bitOr: blendG) bitOr: blendA << 24. ^ result ! Item was removed: - ----- Method: BitBltSimulation>>partitionedMul:with:nBits:nPartitions: (in category 'combination rules') ----- - partitionedMul: word1 with: word2 nBits: nBits nPartitions: nParts - "Multiply word1 with word2 as nParts partitions of nBits each. - This is useful for packed pixels, or packed colors. - Bug in loop version when non-white background" - - | sMask product result dMask | - "In C, integer multiplication might answer a wrong value if the unsigned values are declared as signed. - This problem does not affect this method, because the most significant bit (i.e. the sign bit) will - always be zero (jmv)" - <returnTypeC: 'unsigned int'> - <var: 'word1' type: #'unsigned int'> - <var: 'word2' type: #'unsigned int'> - <var: 'sMask' type: #'unsigned int'> - <var: 'dMask' type: #'unsigned int'> - <var: 'result' type: #'unsigned int'> - <var: 'product' type: #'unsigned int'> - sMask := maskTable at: nBits. "partition mask starts at the right" - dMask := sMask << nBits. - result := (((word1 bitAnd: sMask)+1) * ((word2 bitAnd: sMask)+1) - 1 - bitAnd: dMask) >> nBits. "optimized first step" - nParts = 1 - ifTrue: [ ^result ]. - product := (((word1>>nBits bitAnd: sMask)+1) * ((word2>>nBits bitAnd: sMask)+1) - 1 bitAnd: dMask). - result := result bitOr: product. - nParts = 2 - ifTrue: [ ^result ]. - product := (((word1>>(2*nBits) bitAnd: sMask)+1) * ((word2>>(2*nBits) bitAnd: sMask)+1) - 1 bitAnd: dMask). - result := result bitOr: product << nBits. - nParts = 3 - ifTrue: [ ^result ]. - product := (((word1>>(3*nBits) bitAnd: sMask)+1) * ((word2>>(3*nBits) bitAnd: sMask)+1) - 1 bitAnd: dMask). - result := result bitOr: product << (2*nBits). - ^ result - - " | sMask product result dMask | - sMask := maskTable at: nBits. 'partition mask starts at the right' - dMask := sMask << nBits. - result := (((word1 bitAnd: sMask)+1) * ((word2 bitAnd: sMask)+1) - 1 - bitAnd: dMask) >> nBits. 'optimized first step' - nBits to: nBits * (nParts-1) by: nBits do: [:ofs | - product := (((word1>>ofs bitAnd: sMask)+1) * ((word2>>ofs bitAnd: sMask)+1) - 1 bitAnd: dMask). - result := result bitOr: (product bitAnd: dMask) << (ofs-nBits)]. - ^ result"! Item was added: + ----- Method: BitBltSimulation>>partitionedMul:with:nBits:wordBits: (in category 'combination rules') ----- + partitionedMul: word1 with: word2 nBits: nBits wordBits: wordBits + "Multiply each channel of nBits in word1 and word2. + We assume that for each channel of nBits, we multiply ratios in interval [0..1], scaled by (1 << nBits - 1). + result := ((channel1/scale) * (channel2/scale) * scale) rounded + Or after simplification: + result := (channel1 * channel2 / scale) rounded + This is implemented by first forming the double precision products (channel1 * channel2) on a double-word. + Then dividing each double precision channel by scale, with correctly rounded operation. + With proper tricks, some of these operations can be multiplexed + (all channels are formed in parallel with a single sequence of operation)." + + | channelMask groupMask doubleGroupMask doubleWord1 doubleWord2 doubleWordMul half shift result highWordShift nGroups n2 | + <returnTypeC: 'unsigned int'> + <var: 'word1' type: #'unsigned int'> + <var: 'word2' type: #'unsigned int'> + <var: 'channelMask' type: #'unsigned int'> + <var: 'groupMask' type: #'unsigned int'> + <var: 'half' type: #'unsigned int'> + <var: 'doubleGroupMask' type: #'unsigned long long'> + <var: 'doubleWord1' type: #'unsigned long long'> + <var: 'doubleWord2' type: #'unsigned long long'> + <var: 'doubleWordMul' type: #'unsigned long long'> + <var: 'result' type: #'unsigned int'> + n2 := 2 * nBits. "width of double-precision channel" + channelMask := 1 << nBits - 1. "partition mask starts at the right" + nGroups := wordBits // nBits + 1 // 2. "number of channels that fit in a word, when alternating with group of zeros" + groupMask := channelMask. "form a word mask with alternate nBits 0 and nBits 1, so as to select even channels" + 2 to: nGroups do: [:i | groupMask := groupMask << n2 + channelMask]. + highWordShift := nGroups * n2. "shift for putting odd channels in high-word - usually wordBits, except if wordBits \\ nBits ~= 0" + + doubleWord1 := word1 >> nBits bitAnd: groupMask. "select odd channel interleaved with groups of nBits zeros, so as to leave room for double-precision multiplication" + doubleWord2 := word2 >> nBits bitAnd: groupMask. + doubleWord1 := doubleWord1 << highWordShift + (word1 bitAnd: groupMask). "Put odd channels in high word, and even channels in low word" + doubleWord2 := doubleWord2 << highWordShift + (word2 bitAnd: groupMask). + + half := channelMask >> 1 + 1. "mid-value to add for getting a correctly rounded division" + shift := 0. + doubleWordMul := 0. + 1 to: wordBits // nBits do: [:i | + doubleWordMul := doubleWordMul + ((doubleWord1 >> shift bitAnd: channelMask) * (doubleWord2 >> shift bitAnd: channelMask) + half << shift). "multiply each channel of the two operands" + shift := shift + n2]. + + doubleGroupMask := groupMask. "form a mask for extracting single-precision channels in the double word" + doubleGroupMask := doubleGroupMask << highWordShift + groupMask. + + doubleWordMul := (doubleWordMul >> nBits bitAnd: doubleGroupMask) + doubleWordMul >> nBits bitAnd: doubleGroupMask. "divide by scale" + result := doubleWordMul >> (highWordShift - nBits) + (doubleWordMul bitAnd: groupMask). "compact channels back into a single word" + ^result! Item was changed: ----- Method: BitBltSimulation>>rgbMul:with: (in category 'combination rules') ----- rgbMul: sourceWord with: destinationWord <inline: false> <returnTypeC: 'unsigned int'> <var: 'sourceWord' type: #'unsigned int'> <var: 'destinationWord' type: #'unsigned int'> destDepth < 16 ifTrue: ["Mul each pixel separately" + destDepth = 1 ifTrue: [^self bitAnd: sourceWord with: destinationWord]. + ^ self partitionedMul: sourceWord with: destinationWord nBits: destDepth wordBits: 32]. - ^ self partitionedMul: sourceWord with: destinationWord - nBits: destDepth nPartitions: destPPW]. destDepth = 16 ifTrue: ["Mul RGB components of each pixel separately" + ^ (self partitionedMul: (sourceWord bitAnd: 16rFFFF) with: (destinationWord bitAnd: 16rFFFF) nBits: 5 wordBits: 16) + + ((self partitionedMul: sourceWord>>16 with: destinationWord>>16 nBits: 5 wordBits: 16) << 16)] - ^ (self partitionedMul: sourceWord with: destinationWord - nBits: 5 nPartitions: 3) - + ((self partitionedMul: sourceWord>>16 with: destinationWord>>16 - nBits: 5 nPartitions: 3) << 16)] ifFalse: ["Mul RGBA components of the pixel separately" + ^ self partitionedMul: sourceWord with: destinationWord nBits: 8 wordBits: 32]! - ^ self partitionedMul: sourceWord with: destinationWord - nBits: 8 nPartitions: 4] - - " | scanner | - Display repaintMorphicDisplay. - scanner := DisplayScanner quickPrintOn: Display. - MessageTally time: [0 to: 760 by: 4 do: [:y |scanner drawString: 'qwrepoiuasfd=)(/&()=#!!lkjzxv.,mn124+09857907QROIYTOAFDJZXNBNB,M-.,Mqwrepoiuasfd=)(/&()=#!!lkjzxv.,mn124+09857907QROIYTOAFDJZXNBNB,M-.,M1234124356785678' at: 0@y]]. "! Item was added: + ----- Method: BitBltSimulationTest>>testRgbMulDepth16 (in category 'tests') ----- + testRgbMulDepth16 + | x f1 f2 f3 bb | + x := 1 << 5. + f1 := Form extent: x@x depth: 16. + f2 := Form extent: x@x depth: 16. + 0 to: x-1 do: [:ix | + 0 to: x-1 do: [:iy | + f1 pixelValueAt: ix@iy put: ((ix bitOr: ix+10\\x<<5) bitOr: ix+20\\x<<10). + f2 pixelValueAt: ix@iy put: ((iy bitOr: iy+10\\x<<5) bitOr: iy+20\\x<<10)]]. + f3 := f2 copy. + bb := BitBlt new. + bb setDestForm: f3; sourceForm: f1. + bb sourceX: 0; sourceY: 0; destX: 0; destY: 0. + bb width: x; height: x. + bb combinationRule: Form rgbMul. + bb copyBits. + 0 to: x-1 do: [:ix | + 0 to: x-1 do: [:iy | + "Test that each 5 bits rgb channel is correctly rounded multiplication" + self assert: ((f3 pixelValueAt: ix@iy) >> 10 bitAnd: 31) + = (((f1 pixelValueAt: ix@iy) >> 10 bitAnd: 31) + * ((f2 pixelValueAt: ix@iy) >>10 bitAnd: 31) / (x - 1)) rounded. + self assert: ((f3 pixelValueAt: ix@iy) >> 5 bitAnd: 31) + = (((f1 pixelValueAt: ix@iy) >> 5 bitAnd: 31) + * ((f2 pixelValueAt: ix@iy) >>5 bitAnd: 31) / (x - 1)) rounded. + self assert: ((f3 pixelValueAt: ix@iy) bitAnd: 31) + = (((f1 pixelValueAt: ix@iy) bitAnd: 31) + * ((f2 pixelValueAt: ix@iy) bitAnd: 31) / (x - 1)) rounded]]! Item was added: + ----- Method: BitBltSimulationTest>>testRgbMulDepth1to8 (in category 'tests') ----- + testRgbMulDepth1to8 + "Note that depth=32 and depth=8 have exactly same effect 32bits-word-wise + since we decompose 32 bits depth in four 8-bits channels, ARGB. + Only depth 16 is special, with 3 channels of 5 bits, and 1 dead bit." + #(1 2 4 8) do: [:d | + | x f1 f2 f3 bb | + x := 1 << d. + f1 := Form extent: x@x depth: d. + f2 := Form extent: x@x depth: d. + 0 to: x-1 do: [:ix | + 0 to: x-1 do: [:iy | + f1 pixelValueAt: ix@iy put: ix. + f2 pixelValueAt: ix@iy put: iy]]. + f3 := f2 copy. + bb := BitBlt new. + bb setDestForm: f3; sourceForm: f1. + bb sourceX: 0; sourceY: 0; destX: 0; destY: 0. + bb width: x; height: x. + bb combinationRule: Form rgbMul. + bb copyBits. + 0 to: x-1 do: [:ix | + 0 to: x-1 do: [:iy | + self assert: (f3 pixelValueAt: ix@iy) = ((f1 pixelValueAt: ix@iy) * (f2 pixelValueAt: ix@iy) / (x - 1)) rounded]]]! Item was changed: ----- Method: CCodeGenerator>>generateShiftLeft:on:indent: (in category 'C translation') ----- generateShiftLeft: msgNode on: aStream indent: level "Generate a C bitShift. If the receiver type is unsigned avoid C99 undefined behaviour of left shifting negative values (what?!!?!!? such quiche eating idiocy to treat this like anything other than a truncated left shift) by casting signed receiver types to unsigned and back. If we can determine the result would overflow the word size, cast to a long integer." | rcvr arg castToLong type mustCastBackToSign mustCastToUnsigned canSuffixTheConstant typeIsUnsigned | (self generateAsConstantExpression: msgNode on: aStream) ifTrue: [^self]. rcvr := msgNode receiver. arg := msgNode args first. castToLong := false. (rcvr constantNumbericValueIfAtAllPossibleOrNilIn: self) ifNotNil: [:rcvrVal | (arg constantNumbericValueIfAtAllPossibleOrNilIn: self) ifNil: [castToLong := vmClass notNil and: [vmClass objectMemoryClass wordSize = 8]] ifNotNil: [:argVal | | valueBeyondInt | valueBeyondInt := 1 bitShift: 32. "The default type of const << N is int." castToLong := rcvrVal < valueBeyondInt and: [(rcvrVal bitShift: argVal) >= valueBeyondInt]]]. canSuffixTheConstant := rcvr isConstant and: [rcvr name isEmpty and: [rcvr value >= 0]]. canSuffixTheConstant ifTrue: [aStream nextPutAll: (self cLiteralForUnsignedInteger: rcvr value longlong: castToLong). aStream nextPutAll: ' << '. self emitCExpression: arg on: aStream indent: level. ^self]. type := self typeFor: rcvr in: currentMethod. castToLong := castToLong and: [(self sizeOfIntegralCType: type) < (self sizeOfIntegralCType: #usqLong)]. + typeIsUnsigned := type first = $u or: [type = #'size_t']. - typeIsUnsigned := type first = $u. mustCastToUnsigned := typeIsUnsigned not or: [castToLong or: [(self sizeOfIntegralCType: type) < (self sizeOfIntegralCType: #usqInt)]]. mustCastBackToSign := typeIsUnsigned not. mustCastBackToSign ifTrue: [| promotedType | promotedType := castToLong ifTrue: [#sqLong] ifFalse: [(self sizeOfIntegralCType: type) < (self sizeOfIntegralCType: #sqInt) ifTrue: [#sqInt] ifFalse: [type]]. aStream nextPutAll: '(('; nextPutAll: promotedType; nextPut: $)]. mustCastToUnsigned ifTrue: [| unsigned | unsigned := castToLong ifTrue: [#usqLong] ifFalse: [(self sizeOfIntegralCType: type) < (self sizeOfIntegralCType: #usqLong) ifTrue: [#usqInt] ifFalse: [self unsignedTypeForIntegralType: type]]. aStream nextPutAll: '(('; nextPutAll: unsigned; nextPutAll: ')(']. self emitCExpression: rcvr on: aStream indent: level. mustCastToUnsigned ifTrue: [aStream nextPut: $)]. aStream nextPutAll: ' << '. self emitCExpression: arg on: aStream indent: level. mustCastToUnsigned ifTrue: [aStream nextPut: $)]. mustCastBackToSign ifTrue: [aStream nextPut: $)]! Item was changed: ----- Method: CCodeGenerator>>generateSignedShiftRight:on:indent: (in category 'C translation') ----- generateSignedShiftRight: msgNode on: aStream indent: level "Generate the C code for >>> onto the given stream." | type typeIsUnsigned mustCastToSigned signedType | type := self typeFor: msgNode receiver in: currentMethod. + typeIsUnsigned := type first = $u or: [type = #'size_t']. - typeIsUnsigned := type first = $u. mustCastToSigned := typeIsUnsigned or: ["cast to sqInt if the int is shorter: we want to avoid UB related to a shift exceeeding bit width" (self sizeOfIntegralCType: type) < (self sizeOfIntegralCType: #usqInt)]. mustCastToSigned ifTrue: ["If the variable is a 64-bit type then don't cast it to usqInt (typically a 32-bit type)" signedType := (self sizeOfIntegralCType: type) < (self sizeOfIntegralCType: #usqLong) ifTrue: [#sqInt] ifFalse: [self signedTypeForIntegralType: type]. aStream nextPutAll: '(('; nextPutAll: signedType; nextPutAll: ')('. self emitCExpression: msgNode receiver on: aStream indent: level. aStream nextPutAll: '))'] ifFalse: [aStream nextPutAll: '('. self emitCExpression: msgNode receiver on: aStream indent: level. aStream nextPut: $)]. aStream nextPutAll: ' >> '. self emitCExpression: msgNode args first on: aStream! Item was changed: ----- Method: CCodeGenerator>>signedTypeForIntegralType: (in category 'type inference') ----- signedTypeForIntegralType: aCTypeString (aCTypeString beginsWith: 'unsigned ') ifTrue: [^aCTypeString allButFirst: 8]. (aCTypeString beginsWith: 'usq') ifTrue: [^aCTypeString allButFirst]. + aCTypeString = #'size_t' ifTrue: + ["could be ssize_t if only it were universal... + On all targetted systems so far, this is as long as a pointer type." + ^#sqIntptr_t]. - aCTypeString = 'size_t' ifTrue: [^#usqIntptr_t]. self error: 'unknown type'. ^#long! Item was changed: ----- Method: CCodeGenerator>>unsignedTypeForIntegralType: (in category 'type inference') ----- unsignedTypeForIntegralType: aCTypeString ^aCTypeString first = $u ifTrue: [aCTypeString] ifFalse: [(aCTypeString beginsWith: 'sq') ifTrue: ['u' , aCTypeString] + ifFalse: [aCTypeString = #'size_t' + ifTrue: [aCTypeString] + ifFalse: ['unsigned ' , aCTypeString]]]! - ifFalse: ['unsigned ' , aCTypeString]]! Item was changed: ----- 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 | (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: + [objectMemory marker markAndShouldScan: entryOop]]]. - [objectMemory marker pushOnMarkingStackAndMakeGreyIfNecessary: entryOop]]]. 0 to: primTraceLogIndex - 1 do: [:i| entryOop := primTraceLog at: i. (entryOop ~= 0 and: [objectMemory isNonImmediate: entryOop]) ifTrue: + [objectMemory marker markAndShouldScan: entryOop]]! - [objectMemory marker pushOnMarkingStackAndMakeGreyIfNecessary: entryOop]]! Item was changed: ----- Method: CoInterpreter>>incrementalMarkAndTraceStackPage: (in category 'object memory support') ----- incrementalMarkAndTraceStackPage: thePage | theSP theFP frameRcvrOffset callerFP oop | <var: #thePage type: #'StackPage *'> <var: #theSP type: #'char *'> <var: #theFP type: #'char *'> <var: #frameRcvrOffset type: #'char *'> <var: #callerFP type: #'char *'> <inline: false> 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: + [objectMemory marker markAndShouldScan: oop]. - [objectMemory marker pushOnMarkingStackAndMakeGrey: oop]. theSP := theSP + objectMemory wordSize]. (self frameHasContext: theFP) ifTrue: [self assert: (objectMemory isContext: (self frameContext: theFP)). + objectMemory marker markAndShouldScan: (self frameContext: theFP)]. - objectMemory marker pushOnMarkingStackAndMakeGrey: (self frameContext: theFP)]. (self isMachineCodeFrame: theFP) ifTrue: [self markAndTraceMachineCodeMethod: (self mframeCogMethod: theFP)] + ifFalse: [objectMemory marker markAndShouldScan: (self iframeMethod: theFP)]. - ifFalse: [objectMemory marker pushOnMarkingStackAndMakeGrey: (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: + [objectMemory marker markAndShouldScan: oop]. - [objectMemory marker pushOnMarkingStackAndMakeGrey: oop]. theSP := theSP + objectMemory wordSize]! Item was changed: ----- 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 | 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: + [objectMemory marker markAndShouldScan: oop]. - [objectMemory marker pushOnMarkingStackAndMakeGreyIfNecessary: oop]. oop := traceLog at: i + 1. (objectMemory isImmediate: oop) ifFalse: + [objectMemory marker markAndShouldScan: oop]]! - [objectMemory marker pushOnMarkingStackAndMakeGreyIfNecessary: oop]]! Item was changed: ----- Method: SocketPlugin>>primitiveSocket:connectTo:port: (in category 'primitives') ----- primitiveSocket: socket connectTo: address port: port | addr s okToConnect | <var: #s type: 'SocketPtr'> self primitive: 'primitiveSocketConnectToPort' parameters: #(#Oop #ByteArray #SmallInteger ). addr := self netAddressToInt: (self cCoerce: address to: 'unsigned char *'). "If the security plugin can be loaded, use it to check for permission. If not, assume it's ok" + interpreterProxy failed ifFalse: + [sCCTPfn ~= 0 ifTrue: + [okToConnect := self cCode: ' ((sqInt (*) (sqInt, sqInt)) sCCTPfn)(addr, port)'. + okToConnect ifFalse: + [^ interpreterProxy primitiveFail]]]. - sCCTPfn ~= 0 ifTrue: - [okToConnect := self cCode: ' ((sqInt (*) (sqInt, sqInt)) sCCTPfn)(addr, port)'. - okToConnect ifFalse: - [^ interpreterProxy primitiveFail]]. s := self socketValueOf: socket. interpreterProxy failed ifFalse: [self sqSocket: s ConnectTo: addr Port: port]! Item was changed: ----- Method: SocketPlugin>>primitiveSocket:listenOnPort: (in category 'primitives') ----- primitiveSocket: socket listenOnPort: port "one part of the wierdass dual prim primitiveSocketListenOnPort which was warped by some demented evil person determined to twist the very nature of reality" | s okToListen | <var: #s type: 'SocketPtr '> self primitive: 'primitiveSocketListenOnPort' parameters: #(#Oop #SmallInteger ). s := self socketValueOf: socket. "If the security plugin can be loaded, use it to check for permission. If not, assume it's ok" - sCCLOPfn ~= 0 ifTrue: - [okToListen := self cCode: ' ((sqInt (*) (sqInt, sqInt)) sCCLOPfn)((sqInt)s, port)'. - okToListen ifFalse: - [^ interpreterProxy primitiveFail]]. interpreterProxy failed ifFalse: + [sCCLOPfn ~= 0 ifTrue: + [okToListen := self cCode: ' ((sqInt (*) (sqInt, sqInt)) sCCLOPfn)((sqInt)s, port)'. + okToListen ifFalse: + [^ interpreterProxy primitiveFail]]]. + interpreterProxy failed ifFalse: [self sqSocket: s ListenOnPort: port]! Item was changed: ----- Method: SocketPlugin>>primitiveSocket:listenOnPort:backlogSize: (in category 'primitives') ----- primitiveSocket: socket listenOnPort: port backlogSize: backlog "second part of the wierdass dual prim primitiveSocketListenOnPort which was warped by some demented evil person determined to twist the very nature of reality" | s okToListen | <var: #s type: 'SocketPtr'> self primitive: 'primitiveSocketListenOnPortBacklog' parameters: #(#Oop #SmallInteger #SmallInteger ). "If the security plugin can be loaded, use it to check for permission. If not, assume it's ok" - sCCLOPfn ~= 0 ifTrue: - [okToListen := self cCode: ' ((sqInt (*) (sqInt, sqInt)) sCCLOPfn)((sqInt)s, port)'. - okToListen ifFalse: - [^interpreterProxy primitiveFail]]. s := self socketValueOf: socket. interpreterProxy failed ifFalse: + [sCCLOPfn ~= 0 ifTrue: + [okToListen := self cCode: ' ((sqInt (*) (sqInt, sqInt)) sCCLOPfn)((sqInt)s, port)'. + okToListen ifFalse: + [^interpreterProxy primitiveFail]]]. + interpreterProxy failed ifFalse: [self sqSocket: s ListenOnPort: port BacklogSize: backlog]! Item was changed: ----- Method: SocketPlugin>>primitiveSocket:listenOnPort:backlogSize:interface: (in category 'primitives') ----- primitiveSocket: socket listenOnPort: port backlogSize: backlog interface: ifAddr "Bind a socket to the given port and interface address with no more than backlog pending connections. The socket can be UDP, in which case the backlog should be specified as zero." | s okToListen addr | <var: #s type: #SocketPtr> self primitive: 'primitiveSocketListenOnPortBacklogInterface' parameters: #(#Oop #SmallInteger #SmallInteger #ByteArray). "If the security plugin can be loaded, use it to check for permission. If not, assume it's ok" - sCCLOPfn ~= 0 ifTrue: - [okToListen := self cCode: ' ((sqInt (*) (sqInt, sqInt)) sCCLOPfn)((sqInt)s, port)'. - okToListen ifFalse: - [^ interpreterProxy primitiveFail]]. s := self socketValueOf: socket. + interpreterProxy failed ifFalse: + [sCCLOPfn ~= 0 ifTrue: + [okToListen := self cCode: ' ((sqInt (*) (sqInt, sqInt)) sCCLOPfn)((sqInt)s, port)'. + okToListen ifFalse: + [^ interpreterProxy primitiveFail]]]. addr := self netAddressToInt: (self cCoerce: ifAddr to: #'unsigned char *'). interpreterProxy failed ifFalse: [self sqSocket: s ListenOnPort: port BacklogSize: backlog Interface: addr]! Item was changed: ----- 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 - GCEventLog register: ((aBoolean ifTrue: [GCGreyEvent] + ifFalse: [GCUngreyEvent]) address: objOop)." - 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 - GCEventLog register: ((aBoolean ifTrue: [GCMarkEvent] + ifFalse: [GCUnmarkEvent]) address: objOop)." - 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 changed: ----- Method: Spur64BitMMLESimulator>>unlinkFreeChunk:chunkBytes: (in category 'as yet unclassified') ----- unlinkFreeChunk: freeChunk chunkBytes: chunkBytes + "GCEventLog register: (GCUnlinkEvent address: freeChunk)." - GCEventLog register: (GCUnlinkEvent address: freeChunk). ^ super unlinkFreeChunk: freeChunk chunkBytes: chunkBytes! 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) and: [((manager isMarked: survivor) not or: [tenureCriterion = MarkOnTenure]) and: [tenureCriterion = TenureToShrinkRT or: [(manager isPinned: 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 min: MarkOnTenure) ifTrue: [tenureCriterion = TenureToShrinkRT ifTrue: [manager rtRefCountOf: newOop put: 0]. tenureCriterion = MarkOnTenure ifTrue: [manager setIsMarkedOf: newOop to: true]]. + + manager gc maybeModifyGCFlagsOf: newOop. 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: 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 postCompactionAction. + self finishCompaction.! - currentHeapPointer := self compactSegment: segInfo freeStart: currentHeapPointer segIndex: i]]! Item was changed: ----- Method: SpurIncrementalCompactor>>doIncrementalCompact (in category 'incremental compaction') ----- doIncrementalCompact | 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: '; printNum: segInfo segStart; print: ' to: '; printNum: segInfo segStart + segInfo segSize; print: ' into: ' ; printNum: segmentToFill segStart; tab; flush. + currentHeapPointer := self compactSegment: segInfo freeStart: currentHeapPointer segIndex: i. self assert: manager totalFreeOldSpace = manager totalFreeListBytes. self flag: #Todo. "for now we compact on segment at a time" ^ currentSegment = (manager numSegments - 1) ifTrue: [true] ifFalse: [false]]]. ^ true! Item was changed: ----- Method: SpurIncrementalCompactor>>finishCompaction (in category 'incremental compaction') ----- finishCompaction - self setFreeChunkOfCompactedIntoSegment. - self postCompactionAction. self resetCompactor! Item was changed: ----- 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 *'> - segmentToFill := nil. 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 changed: ----- Method: SpurIncrementalCompactor>>incrementalCompact (in category 'api') ----- incrementalCompact + self initCompactionIfNecessary. - self initializeCompactionIfNecessary. shouldCompact + ifTrue: [ | finishedCompacting | + finishedCompacting := self doIncrementalCompact. + self postCompactionAction. + + finishedCompacting - ifTrue: [ - self doIncrementalCompact ifTrue: [ self finishCompaction. ^ true]] ifFalse: [^ 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: [currentHeapPointer := segmentToFill segStart]]. + + isCompacting := true. + + self assert: currentSegment notNil + ! Item was removed: - ----- Method: SpurIncrementalCompactor>>initializeCompactionIfNecessary (in category 'incremental compaction') ----- - initializeCompactionIfNecessary - - isCompacting - ifFalse: [self assertNoSegmentBeingCompacted. - self planCompactionAndReserveSpace. - - self assert: manager totalFreeOldSpace = manager totalFreeListBytes. - - shouldCompact ifTrue: [currentHeapPointer := segmentToFill segStart]]. - - isCompacting := true. - - self assert: currentSegment notNil - ! Item was changed: ----- Method: SpurIncrementalCompactor>>resetCompactor (in category 'as yet unclassified') ----- resetCompactor + self setFreeChunkOfCompactedIntoSegment. + isCompacting := false. shouldCompact := nil. currentHeapPointer := nil. currentSegment := 0! Item was changed: ----- Method: SpurIncrementalCompactor>>segmentToFill (in category 'as yet unclassified') ----- segmentToFill + <cmacro: '() GIV(segmentToFill)'> ^ segmentToFill! Item was changed: ----- Method: SpurIncrementalCompactor>>setFreeChunkOfCompactedIntoSegment (in category 'segment access') ----- setFreeChunkOfCompactedIntoSegment segmentToFill ifNil: [^ self]. 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] + ! - at: currentHeapPointer.! Item was added: + ----- Method: SpurIncrementalGarbageCollector class>>declareCVarsIn: (in category 'as yet unclassified') ----- + declareCVarsIn: aCCodeGenerator + super declareCVarsIn: aCCodeGenerator. + aCCodeGenerator var: 'phase' declareC: 'sqInt phase = 0'! Item was changed: ----- Method: SpurIncrementalGarbageCollector class>>initialize (in category 'as yet unclassified') ----- initialize + InMarkingPhase := 0. + InSweepingPhase := 1. + InCompactingPhase := 2.! - InCompactingPhase := 0. - InMarkingPhase := 1. - InSweepingPhase := 2.! Item was changed: ----- Method: SpurIncrementalGarbageCollector class>>simulatorClass (in category 'as yet unclassified') ----- simulatorClass + "^ SpurIncrementalGarbageCollectorSimulator" + ^ self! - ^ SpurIncrementalGarbageCollectorSimulator! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>doIncrementalCollect (in category 'as yet unclassified') ----- doIncrementalCollect + - phase = InMarkingPhase ifTrue: [ + coInterpreter cr; print: 'start marking '; tab; flush. marker incrementalMarkObjects ifTrue: [ manager allPastSpaceObjectsDo: [:obj | self assert: (manager isWhite: obj)]. - manager - setCheckForLeaks: GCCheckFreeSpace + GCModeFull; - runLeakCheckerFor: GCModeFull; - checkFreeSpace: GCModeFull. "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 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; + checkFreeSpace: GCModeFull. + + ^ self] + ifFalse: [coInterpreter cr; print: 'finish marking pass'; tab; flush.manager runLeakCheckerFor: GCModeIncremental]]. - ifFalse: [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. + phase := InCompactingPhase. ^ self]]. phase = InCompactingPhase ifTrue: [ + 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. - ifTrue: [phase := InMarkingPhase. ^ self]]! Item was changed: ----- 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. - "we are not sweeping anymore => reset it" - allocatorShouldAllocateBlack := false. - compactor resetComponents. - manager shutDownGlobalIncrementalGC: true. 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. + + "mark completely" + [phase = InMarkingPhase] + whileTrue: [self doIncrementalCollect]. + "do rest of collection" + [phase ~= InMarkingPhase] + whileTrue: [self doIncrementalCollect]. - marker completeMarkObjects. - compactor sweepAndCompact. + manager setHeapSizeAtPreviousGC. - "we do not need to make a complete mark, we just need to resolve and delete forwarders" - "marker resolveAllForwarders" - "lets be lazy here as this won't be the final implementation" - marker completeMarkObjects. + coInterpreter cr; print: 'end fullGC '; tab; flush. + + ^(manager freeLists at: 0) ~= 0 + ifTrue: [manager bytesInBody: manager findLargestFreeChunk] + ifFalse: [0]! - manager setHeapSizeAtPreviousGC! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>maybeModifyGCFlagsOf: (in category 'as yet unclassified') ----- 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: [allocatorShouldAllocateBlack and: [objOop >= compactor currentSweepingEntity]]) 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 changed: ----- 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]). - self assert: context kind = #mutator. super doIncrementalCollect. + + context kind = #fullGC + ifTrue: [GCEventLog instance pushContext: context] + ifFalse: [GCEventLog instance pushMutatorContext] + ! - GCEventLog instance pushMutatorContext! Item was added: + ----- Method: SpurIncrementalGarbageCollectorSimulator>>fullGC (in category 'global') ----- + fullGC + + GCEventLog + inContext: #fullGC + do: [super fullGC]! Item was changed: + ----- Method: SpurIncrementalGarbageCollectorSimulator>>initialize (in category 'initialize-release') ----- - ----- Method: SpurIncrementalGarbageCollectorSimulator>>initialize (in category 'as yet unclassified') ----- initialize super initialize. GCEventLog reset! Item was changed: + ----- Method: SpurIncrementalGarbageCollectorSimulator>>manager: (in category 'accessing') ----- - ----- Method: SpurIncrementalGarbageCollectorSimulator>>manager: (in category 'as yet unclassified') ----- manager: manager super manager: manager. GCEventLog instance manager: manager! Item was changed: ----- Method: SpurIncrementalMarker class>>simulatorClass (in category 'as yet unclassified') ----- simulatorClass + "^ SpurIncrementalMarkerSimulation" + ^ self! - ^ SpurIncrementalMarkerSimulation! Item was changed: ----- 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 initializeForNewMarkingPassIfNecessary. self pushAllRootsOnMarkStack. self completeMark. self finishMarking. + + manager gc compactor setInitialSweepingEntity. + manager gc compactor freePastSegmentsAndSetSegmentToFill. + manager runLeakCheckerFor: GCModeFull. ! Item was changed: ----- 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. - self initializeForNewMarkingPassIfNecessary. [ | 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! Item was removed: - ----- Method: SpurIncrementalMarker>>initializeForNewMarkingPassIfNecessary (in category 'marking-initialization') ----- - initializeForNewMarkingPassIfNecessary - - 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! Item was changed: ----- Method: SpurIncrementalMarker>>isLeafInObjectGraph: (in category 'barrier') ----- isLeafInObjectGraph: anObject + ^ (manager isImmediate: anObject)! - ^ (manager isImmediate: anObject) or: [manager isPureBitsNonImm: anObject]! Item was changed: ----- 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 changed: ----- 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: slot ofObject: objOop withInitialValue: slot]. self markAndShouldScan: slot]]! Item was changed: ----- Method: SpurIncrementalMarker>>pushNewSpaceReferencesOnMarkingStack (in category 'root-scanning') ----- pushNewSpaceReferencesOnMarkingStack manager allNewSpaceObjectsDo: [:objOop | | format | format := manager formatOf: 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 changed: ----- 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" + (self marking and: [(self isLeafInObjectGraph: value) not and: [(manager isOldObject: anObject) and: [(manager isOldObject: value) and: [manager isMarked: anObject]]]]) - (self marking and: [(self isLeafInObjectGraph: anObject) not and: [(self isLeafInObjectGraph: value) not and: [(manager isOldObject: anObject) and: [(manager isOldObject: value) and: [manager isMarked: anObject]]]]]) ifTrue: [self pushOnMarkingStackAndMakeGreyIfNecessary: value]! Item was added: + ----- Method: SpurIncrementalMarkerSimulation>>initForNewMarkingPassIfNecessary (in category 'marking-initialization') ----- + initForNewMarkingPassIfNecessary + + ^ GCEventLog + inContext: #markingInit + do: [super initForNewMarkingPassIfNecessary]! Item was removed: - ----- Method: SpurIncrementalMarkerSimulation>>initializeForNewMarkingPassIfNecessary (in category 'marking-initialization') ----- - initializeForNewMarkingPassIfNecessary - - ^ GCEventLog - inContext: #markingInit - do: [super initializeForNewMarkingPassIfNecessary]! Item was changed: ----- Method: SpurIncrementalSweepAndCompact class>>simulatorClass (in category 'as yet unclassified') ----- simulatorClass + "^ SpurIncrementalSweepAndCompactSimulator" + ^ self! - ^ SpurIncrementalSweepAndCompactSimulator! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>setInitialSweepingEntity (in category 'as yet unclassified') ----- + setInitialSweepingEntity + + sweeper currentSweepingEntity: manager firstObject! Item was changed: ----- Method: SpurIncrementalSweeper class>>simulatorClass (in category 'as yet unclassified') ----- simulatorClass + "^ SpurIncrementalSweeperSimulator" + ^ self! - ^ SpurIncrementalSweeperSimulator! Item was changed: ----- 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)] - self canUseAsFreeSpace: next] whileTrue: [currentObj := next]. + + currentSegmentUnused := currentSegmentUnused + bytes. - ^ manager addFreeChunkWithBytes: bytes at: start! Item was changed: ----- 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. - manager unlinkFreeChunk: currentObj chunkBytes: (manager bytesInBody: currentObj). - manager totalFreeOldSpace: manager totalFreeOldSpace - (manager bytesInBody: 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>>completeSweepCurrentSweepingEntity (in category 'api - incremental') ----- + completeSweepCurrentSweepingEntity + + (self canUseAsFreeSpace: currentSweepingEntity) + ifTrue: [currentSweepingEntity := self bulkFreeChunkFrom: currentSweepingEntity] + ifFalse: [self unmarkAndUpdateStats]. + ! Item was changed: ----- 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. + - currentSweepingEntity := manager firstObject. [self oop: currentSweepingEntity isLessThan: manager endOfMemory] whileTrue: + [currentSweepingEntity = currentSegmentsBridge + ifTrue: [self advanceSegment] + ifFalse: [self completeSweepCurrentSweepingEntity]. + + currentSweepingEntity := self nextSweepingEntity]. - [(self canUseAsFreeSpace: currentSweepingEntity) - ifTrue: [currentSweepingEntity := self bulkFreeChunkFrom: currentSweepingEntity] - ifFalse: [self unmark: currentSweepingEntity]. - currentSweepingEntity := manager objectAfter: currentSweepingEntity limit: manager endOfMemory]. manager checkFreeSpace: GCModeFull. + + "not sure if I need this (probably not), but it was in the original implementation" manager unmarkSurvivingObjectsForCompact.! Item was changed: ----- 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. - currentSweepingEntity :=self nextSweepingEntity . currentsCycleSeenObjectCount >= MaxObjectsToFree ifTrue: [^ false]]. manager checkFreeSpace: GCModeIncremental. ^ true! Item was changed: ----- Method: SpurIncrementalSweeper>>incrementalSweep (in category 'api - incremental') ----- incrementalSweep <inline: #never> "for profiling" + self initIfNecessary. - self initializeIfNecessary. 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 removed: - ----- Method: SpurIncrementalSweeper>>initializeIfNecessary (in category 'api - incremental') ----- - initializeIfNecessary - - isCurrentlySweeping - ifFalse: [currentSegmentUsed := currentSegmentUnused := 0. - currentSegmentsIndex := 0. - currentSegmentsBridge := manager segmentManager bridgeAt: currentSegmentsIndex. - - currentSweepingEntity := manager firstObject. - - isCurrentlySweeping := true] - ! Item was changed: ----- 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 := nil. currentSegmentUsed := nil. currentSegmentUnused := nil. currentSegmentsIndex := nil. + currentsCycleSeenObjectCount := 0 - currentsCycleSeenObjectCount := nil ! Item was added: + ----- Method: SpurIncrementalSweeperSimulator>>initIfNecessary (in category 'api - incremental') ----- + initIfNecessary + + ^ GCEventLog + inContext: #sweepInit + do: [super initIfNecessary]! Item was removed: - ----- Method: SpurIncrementalSweeperSimulator>>initializeIfNecessary (in category 'api - incremental') ----- - initializeIfNecessary - - ^ GCEventLog - inContext: #sweepInit - do: [super initializeIfNecessary]! Item was changed: ----- Method: SpurMemoryManager>>addFreeChunkWithBytes:at: (in category 'free space') ----- addFreeChunkWithBytes: bytes at: address + + <var: 'aCString' 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>>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: [marker 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 ifTrue: [self isMarked: obj] ifFalse: [true]) ifTrue: [(self isNormalObject: obj) ifTrue: [gc 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: [(self isSegmentBridge: obj) ifFalse: [self setIsMarkedOf: obj to: false]]]]]. self assert: (self isEmptyObjStack: markStack). gc 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 changed: ----- Method: SpurMemoryManager>>checkHeapFreeSpaceIntegrity (in category 'debug support') ----- checkHeapFreeSpaceIntegrity "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. + coInterpreter longPrintOop: obj. 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. + coInterpreter longPrintOop: obj. 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. + coInterpreter longPrintOop: obj. + ok := false]. + fieldOop := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj. - [(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. + coInterpreter longPrintOop: obj. + ok := false]. + (self isLilliputianSize: (self bytesInBody: obj)) ifFalse: + [fieldOop := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: obj. - 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: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; eekcr. + coInterpreter longPrintOop: obj. + 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. + coInterpreter longPrintOop: obj. + ok := false]]]. + total := total + (self bytesInBody: obj)]] + - [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. + coInterpreter longPrintOop: obj. ok := false]]]]]]. + + total - totalFreeOldSpace ~= 0 ifTrue: - total ~= totalFreeOldSpace 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 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 changed: ----- Method: SpurMemoryManager>>fullGC (in category 'gc - global') ----- fullGC <doNotGenerate> + ^ gc fullGC! - gc fullGC! 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. marker 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. - gc allocatorShouldAllocateBlack ifTrue: [self setIsMarkedOf: freeChunk to: true]. 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 changed: ----- 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 | "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. + objectMemory marker markAndShouldScan: objectMemory specialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes" - objectMemory marker pushOnMarkingStackAndMakeGreyIfNecessary: objectMemory specialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes" (objectMemory isImmediate: newMethod) ifFalse: + [objectMemory marker markAndShouldScan: newMethod]. - [objectMemory marker pushOnMarkingStackAndMakeGreyIfNecessary: newMethod]. self incrementalTraceProfileState. + tempOop = 0 ifFalse: [objectMemory marker markAndShouldScan: tempOop]. + tempOop2 = 0 ifFalse: [objectMemory marker markAndShouldScan: tempOop2]. - tempOop = 0 ifFalse: [objectMemory marker pushOnMarkingStackAndMakeGreyIfNecessary: tempOop]. - tempOop2 = 0 ifFalse: [objectMemory marker pushOnMarkingStackAndMakeGreyIfNecessary: tempOop2]. "V3 memory manager support" 1 to: objectMemory remapBufferCount do: [:i | oop := objectMemory remapBuffer at: i. + (objectMemory isImmediate: oop) ifFalse: [objectMemory marker markAndShouldScan: oop]]! - (objectMemory isImmediate: oop) ifFalse: [objectMemory marker pushOnMarkingStackAndMakeGreyIfNecessary: oop]]! Item was changed: ----- Method: VMClass class>>openSpurMultiWindowBrowser (in category 'utilities') ----- openSpurMultiWindowBrowser "Answer a new multi-window browser on the Spur classes, the Cog StackInterpreter classes, and the support classes" "self openSpurMultiWindowBrowser" | b | b := Browser open. + #( SpurIncrementalGarbageCollector SpurMemoryManager Spur32BitMemoryManager Spur64BitMemoryManager - #( SpurIncrementalMarker SpurMemoryManager Spur32BitMemoryManager Spur64BitMemoryManager SpurGenerationScavenger SpurSegmentManager Spur32BitMMLESimulator SpurGenerationScavengerSimulator InterpreterPrimitives StackInterpreter StackInterpreterPrimitives VMStructType VMMaker CCodeGenerator TMethod) do: [:className| (Smalltalk classNamed: className) ifNotNil: [:class| b selectCategoryForClass: class; selectClass: class]] separatedBy: [b multiWindowState addNewWindow]. b multiWindowState selectWindowIndex: 1!

2 1

VM Maker: VMMaker.oscog.seperateMarking-WoC.3257.mcz
by commits＠source.squeak.org 31 Aug '22

31 Aug '22

Tom Braun uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog.seperateMarking-WoC.3257.mcz ==================== Summary ==================== Name: VMMaker.oscog.seperateMarking-WoC.3257 Author: WoC Time: 31 August 2022, 9:00:41.089802 pm UUID: d53709dc-bdaf-487e-bb8b-e47510bf5cc6 Ancestors: VMMaker.oscog.seperateMarking-WoC.3256 - small refactoring in Compactor - mark forwarders if neccessary so they get not garbage collected early =============== Diff against VMMaker.oscog.seperateMarking-WoC.3256 =============== Item was changed: + ----- Method: SpurGarbageCollector>>initialize (in category 'initialize-release') ----- - ----- Method: SpurGarbageCollector>>initialize (in category 'nil') ----- initialize allocatorShouldAllocateBlack := false! Item was added: + ----- Method: SpurGarbageCollector>>maybeModifyForwarder: (in category 'object creation barriers') ----- + maybeModifyForwarder: objOop + + <doNotGenerate>! Item was changed: + ----- Method: SpurGarbageCollector>>maybeModifyGCFlagsOf: (in category 'object creation barriers') ----- - ----- Method: SpurGarbageCollector>>maybeModifyGCFlagsOf: (in category 'as yet unclassified') ----- maybeModifyGCFlagsOf: objOop <doNotGenerate>! 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 changed: ----- Method: SpurIncrementalCompactor>>compactSegment:freeStart:segIndex: (in category 'incremental compaction') ----- compactSegment: segInfo freeStart: initialFreeStart segIndex: segIndex <var: 'segInfo' type: #'SpurSegmentInfo *'> + | currentEntity fillStart bytesToCopy bridge | - | currentEntity fillStart bytesToCopy bridge copy | 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." - self assert: (manager isPinned: currentEntity) not. bytesToCopy := manager bytesInBody: currentEntity. + self migrate: currentEntity sized: bytesToCopy to: fillStart. - manager memcpy: fillStart asVoidPointer _: (manager startOfObject: currentEntity) asVoidPointer _: bytesToCopy. - copy := manager objectStartingAt: fillStart. - (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: currentEntity to: (manager objectStartingAt: 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 changed: ----- Method: SpurIncrementalCompactor>>doIncrementalCompact (in category 'incremental compaction') ----- doIncrementalCompact | 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: '; printNum: segInfo segStart; + print: ' to: '; printNum: segInfo segStart + segInfo segSize; + print: ' into: ' ; printNum: segmentToFill segStart; tab; flush. - coInterpreter cr; print: 'Compact from: '; printNum: segInfo segStart; print: ' to: '; printNum: segInfo segStart + segInfo segSize; print: ' into: ' ; printNum: segmentToFill segStart; tab; flush. currentHeapPointer := self compactSegment: segInfo freeStart: currentHeapPointer segIndex: i. self assert: manager totalFreeOldSpace = manager totalFreeListBytes. self flag: #Todo. "for now we compact on segment at a time" ^ currentSegment = (manager numSegments - 1) ifTrue: [true] ifFalse: [false]]]. ^ true! Item was changed: ----- 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) - ((self isSegmentBeingCompacted: segInfo) or: [segInfo containsPinned or: [manager segmentManager isEmptySegment: 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>>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 changed: ----- Method: SpurIncrementalGarbageCollector>>doIncrementalCollect (in category 'as yet unclassified') ----- doIncrementalCollect phase = InMarkingPhase ifTrue: [ coInterpreter cr; print: 'start marking '; tab; flush. marker incrementalMarkObjects ifTrue: [ manager allPastSpaceObjectsDo: [:obj | self assert: (manager isWhite: obj)]. + manager allOldSpaceObjectsDo: [:ea | (manager isForwarded: ea) ifTrue: [self halt] ]. "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 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; 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. phase := InCompactingPhase. ^ self]]. phase = InCompactingPhase ifTrue: [ 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 changed: ----- 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. + self halt. - coInterpreter cr; print: 'start fullGC '; tab; flush. 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]. "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>>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 already black object gets a forwarding pointer -> it will not be followed in this + marking pass and during sweeping the forwardgin pointer will get removes). + 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 changed: + ----- Method: SpurIncrementalGarbageCollector>>maybeModifyGCFlagsOf: (in category 'object creation barriers') ----- - ----- Method: SpurIncrementalGarbageCollector>>maybeModifyGCFlagsOf: (in category 'as yet unclassified') ----- 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: [allocatorShouldAllocateBlack and: [objOop >= compactor currentSweepingEntity]]) ifTrue: [manager setIsMarkedOf: objOop to: true]! 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]!

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev August 2022