Vm-dev September 2022

vm-dev@lists.squeakfoundation.org

11 participants
21 discussions

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

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev September 2022