Vm-dev August 2022

vm-dev@lists.squeakfoundation.org

11 participants
75 discussions

OSVM on WebAssembly
by Manuel Leuenberger 31 Aug '22

31 Aug '22

Hi, Ever since WebAssembly became a thing, I was wondering if this could become a target for VMs. People are already compiling FFMPEG and other complex tools. So I thought I would try as well. So here I am to report to whom it may concern: OSVM compiles to WebAssembly, starts up (nearly), then looping infinitely Meaning: The VM mmaps the image file, loads plugins (SecurityPlugin made EXTERNAL), starts interpreter loop, but then loops the same bytecode sequence forever Code lives at https://github.com/maenu/opensmalltalk-vm/tree/Cog/building/minheadless.cma… <https://github.com/maenu/opensmalltalk-vm/tree/Cog/building/minheadless.cma…> if you want to try it out. Below is the current Readme, including a short list of issues. Maybe some of you could give me a hint? Cheers, Manuel pharo.stack.spur.wasm Compiles OSVM Stack interpreter to WebAssembly using the Emscripten compiler. Emscripten can be used as a drop-in replacement for gcc/clang and cmake. Based on MinHeadless Linux 32bit sources, as Emscripten provides Linux-like environment (pthreads, nanosleep, dlopen, file system). Check the latest few commits of maenu to see changed files. <https://github.com/maenu/opensmalltalk-vm/tree/Cog/building/minheadless.cma…>Current issues Most adjustments are just putting EMSCRIPTEN in a macro or script. Should be fine, but should be tested to not interfere with other builds. Compiles and runs, but seems to be stuck in initial GC and Heartbeat. Those could be related to incorrect get/set64() implementation. Removed mmap address hint, as it caused errors. Using argv eval '1 + 3' to do a simple eval does not terminate. Interpreter repeats these bytecodes forever (what is this?): 332 384 385 348 501 339 320 401 272 380 <https://github.com/maenu/opensmalltalk-vm/tree/Cog/building/minheadless.cma…>Build & Run <https://github.com/maenu/opensmalltalk-vm/tree/Cog/building/minheadless.cma…>1. Install Emscripten I installed Emscripten SDK <https://emscripten.org/docs/getting_started/downloads.html> to get an all-in-one package. <https://github.com/maenu/opensmalltalk-vm/tree/Cog/building/minheadless.cma…>2. Grab an image Grab a 32bit Smalltalk image and but it in the image folder. I used Pharo 9. cd building/minheadless.cmake/x86/pharo.stack.spur.wasm mkdir image cd image curl https://get.pharo.org/32/90 | bash <https://github.com/maenu/opensmalltalk-vm/tree/Cog/building/minheadless.cma…>3. Build VM ./mvm_configure_variant debug Debug && make -C debug install <https://github.com/maenu/opensmalltalk-vm/tree/Cog/building/minheadless.cma…>4. Run a web server emrun --port 9090 --serve_root ../../../../ --no_browser . <https://github.com/maenu/opensmalltalk-vm/tree/Cog/building/minheadless.cma…>5. Launch VM http://localhost:9090/building/minheadless.cmake/x86/pharo.stack.spur.wasm/… <http://localhost:9090/building/minheadless.cmake/x86/pharo.stack.spur.wasm/…> <https://github.com/maenu/opensmalltalk-vm/tree/Cog/building/minheadless.cma…>6. Inspect running VM The VM is compiled with DWARF debug information, which is understood by the Chrome debugger. So we can step through the C sources of the WebAssembly, pretty nifty. <https://github.com/maenu/opensmalltalk-vm/tree/Cog/building/minheadless.cma…>Resources Inspect WebAssembly (at the bottom) <https://webassembly.org/getting-started/developers-guide/> Emscripten doc (Porting) <https://emscripten.org/docs/porting/index.html> Emscripten settings <https://emsettings.surma.technology/>

2 6

Re: [Vm-dev] [OpenSmalltalk/opensmalltalk-vm] Rescue MSVC builds. There is no strings.h in MSVC. (33cde32)
by Nicolas Cellier 31 Aug '22

31 Aug '22

Oh, and we also have another `#define bzero` in sqPlatformSpecific.h https://github.com/OpenSmalltalk/opensmalltalk-vm/blob/33cde325ebdb166bcafe… -- Reply to this email directly or view it on GitHub: https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/33cde325ebdb166bca… You are receiving this because you are subscribed to this thread. Message ID: <OpenSmalltalk/opensmalltalk-vm/commit/33cde325ebdb166bcafeb2ae78c63cab26976588/82707713(a)github.com>

1 0

Re: [Vm-dev] [OpenSmalltalk/opensmalltalk-vm] Rescue MSVC builds. There is no strings.h in MSVC. (33cde32)
by Nicolas Cellier 31 Aug '22

31 Aug '22

Oups sorry for that. Maybe we could add the MSVC builds in github actions? On the other hand, it seems that bzero and bcopy are deprecated...<br> https://stackoverflow.com/questions/3492647/what-are-the-alternative-for-wi… Maybe we'd rather replace'em all, especially since we're in a windows specific repository. -- Reply to this email directly or view it on GitHub: https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/33cde325ebdb166bca… You are receiving this because you are subscribed to this thread. Message ID: <OpenSmalltalk/opensmalltalk-vm/commit/33cde325ebdb166bcafeb2ae78c63cab26976588/82706830(a)github.com>

1 0

Change notification: squeaksource.com migration to new service provider today
by David T. Lewis 31 Aug '22

31 Aug '22

As part of an overall project to move squeak.org services to a new service provider (hetzner.com), the https://squeaksource.com server will be migrated today, 31 August, beginning at 20:00 UTC. Due to time required for DNS updates to propagate, the change will take effect over a number of hours (expect up to one day). This is the general purpose squeaksource.com server, and does not affect http://source.squeak.org, which will be migrated separately at a later date. What you need to know: For most people, no change will be noticed. Read access to repositories will continue with little or no interruption. If you are committing updates to existing projects, there is a risk of those updates being committed to the "wrong" server during the transition period. No data or files will be lost, but some updates may need to be re-applied. The squeaksource.com administrator will be watching for this and will either fix any missing updates or request the affected project administrator to do so. If you are a project administrator or if you are planning to create a new project on squeaksource.com, please avoid making changes during the transition period. In the event of problems, please report the concern here on the squeak-dev list. If you do not have access to that list, you can report the concern to lewis(a)mail.msen.com. Dave

1 0

[OpenSmalltalk/opensmalltalk-vm] Cannot connect to SSL host (Issue #652)
by unique75m 31 Aug '22

31 Aug '22

The following code worked in the past. Now i get an error -5. Where can i find an explanation about this error? I guess the server side has changed and possibly Squeak SSL does not support that. I can connect to the same server on VisualWorks with the TLS plugin, which uses only an OpenSSL library. I do not know what Squeak does in its primitives. | stream | stream := SecureSocketStream openConnectionToHostNamed: 'stream.data.alpaca.markets' port: 443. stream sslConnect. stream binary. stream halt. stream close This example with another server is working | stream | stream := SecureSocketStream openConnectionToHostNamed: 'quotes-ws.boerse-go.de' port: 443. stream sslConnect. stream binary. stream halt. stream close -- Reply to this email directly or view it on GitHub: https://github.com/OpenSmalltalk/opensmalltalk-vm/issues/652 You are receiving this because you are subscribed to this thread. Message ID: <OpenSmalltalk/opensmalltalk-vm/issues/652(a)github.com>

3 9

[OpenSmalltalk/opensmalltalk-vm] 33cde3: Rescue MSVC builds. There is no strings.h in MSVC.
by Eliot Miranda 30 Aug '22

30 Aug '22

Branch: refs/heads/Cog Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: 33cde325ebdb166bcafeb2ae78c63cab26976588 https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/33cde325ebdb166bca… Author: Eliot Miranda <eliot.miranda(a)gmail.com> Date: 2022-08-30 (Tue, 30 Aug 2022) Changed paths: M platforms/win32/vm/sqWin32Window.c Log Message: ----------- Rescue MSVC builds. There is no strings.h in MSVC.

1 0

[OpenSmalltalk/opensmalltalk-vm] 1a5240: [SqueakSSL/unix/openssl] Fix for OpenSSL3
by Tobias Pape 28 Aug '22

28 Aug '22

Branch: refs/heads/virtend Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: 1a5240be4df93c0bc1fe3f7618d3184fb400c6a3 https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/1a5240be4df93c0bc1… Author: Tobias Pape <tobias(a)netshed.de> Date: 2022-08-28 (Sun, 28 Aug 2022) Changed paths: M platforms/unix/plugins/SqueakSSL/openssl_overlay.h M platforms/unix/plugins/SqueakSSL/sqUnixOpenSSL.inc Log Message: ----------- [SqueakSSL/unix/openssl] Fix for OpenSSL3 OpenSSL 3 deprecated SSL_get_peer_certificate, made it a macro and an provides SSL_get{0,1}_peer_certificate instead. Why even more complicating that already messed API is beyond me. Not promising ABI stability is well known for OpenSSL but, why the HECK not simply providing an Alias Symbol instead of UNNECESSARILY ripping the symbol out of that innocent object file? Also, we now need a load-time disambiguation of which symbol to use. (if you find a rant in this message, you can keep it)

1 0

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

28 Aug '22

Tom Braun uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog.seperateMarking-WoC.3255.mcz ==================== Summary ==================== Name: VMMaker.oscog.seperateMarking-WoC.3255 Author: WoC Time: 28 August 2022, 5:32:49.869998 pm UUID: 9fe52120-7f24-42ff-b618-3e9ffa920a42 Ancestors: VMMaker.oscog.seperateMarking-WoC.3254 can open a stack vm for a short time now - more asserts - fixed issues with compacting (forwarders and reserved memory management) - resetting for incremental collector parts - provisionally implementation of fullGC (based on incremental components -> should be changed if possible) - minor refactorings in sweeper - allocate black array created in allInstancesOf =============== Diff against VMMaker.oscog.seperateMarking-WoC.3254 =============== Item was changed: ----- Method: Spur32BitMemoryManager>>allocateSlotsForPinningInOldSpace:bytes:format:classIndex: (in category 'allocation') ----- allocateSlotsForPinningInOldSpace: numSlots bytes: totalBytes format: formatField classIndex: classIndex "Answer the oop of a chunk of space in oldSpace with numSlots slots. Try and allocate in a segment that already includes pinned objects. The header of the result will have been filled-in but not the contents." <var: #totalBytes type: #usqInt> <inline: false> | chunk | chunk := self allocateOldSpaceChunkOfBytes: totalBytes suchThat: [:f| (segmentManager segmentContainingObj: f) containsPinned]. chunk ifNil: [chunk := self allocateOldSpaceChunkOfBytes: totalBytes. chunk ifNil: [^nil]. (segmentManager segmentContainingObj: chunk) containsPinned: true]. numSlots >= self numSlotsMask ifTrue: "for header parsing we put a saturated slot count in the prepended overflow size word" [self flag: #endianness. self longAt: chunk put: numSlots. self longAt: chunk + 4 put: self numSlotsMask << self numSlotsHalfShift. self long64At: chunk + self baseHeaderSize put: ((self headerForSlots: self numSlotsMask format: formatField classIndex: classIndex) bitOr: 1 << self pinnedBitShift). self flag: #Todo. "later on we probably want to do this in the call above" + gc maybeModifyGCFlagsOf: chunk + self baseHeaderSize. - gc maybeModifyGCFlagsOf: chunk. self checkFreeSpace: GCModeNewSpace. ^chunk + self baseHeaderSize]. self long64At: chunk put: ((self headerForSlots: numSlots format: formatField classIndex: classIndex) bitOr: 1 << self pinnedBitShift). self flag: #Todo. "later on we probably want to do this in the call above" gc maybeModifyGCFlagsOf: chunk. self checkFreeSpace: GCModeNewSpace. ^chunk! Item was changed: ----- Method: Spur32BitMemoryManager>>allocateSlotsInOldSpace:bytes:format:classIndex: (in category 'allocation') ----- allocateSlotsInOldSpace: numSlots bytes: totalBytes format: formatField classIndex: classIndex "Answer the oop of a chunk of space in oldSpace with numSlots slots. The header will have been filled-in but not the contents. If no memory is available answer nil." <var: #totalBytes type: #usqInt> <inline: false> | chunk | chunk := self allocateOldSpaceChunkOfBytes: totalBytes. chunk ifNil: [^nil]. numSlots >= self numSlotsMask ifTrue: "for header parsing we put a saturated slot count in the prepended overflow size word" [self flag: #endianness. self longAt: chunk put: numSlots. self longAt: chunk + 4 put: self numSlotsMask << self numSlotsHalfShift. self long64At: chunk + self baseHeaderSize put: (self headerForSlots: self numSlotsMask format: formatField classIndex: classIndex). self flag: #Todo. "later on we probably want to do this in the call above" + gc maybeModifyGCFlagsOf: chunk + self baseHeaderSize. - gc maybeModifyGCFlagsOf: chunk. self checkFreeSpace: GCModeNewSpace. ^chunk + self baseHeaderSize]. self long64At: chunk put: (self headerForSlots: numSlots format: formatField classIndex: classIndex). self flag: #Todo. "later on we probably want to do this in the call above" gc maybeModifyGCFlagsOf: chunk. self checkFreeSpace: GCModeNewSpace. ^chunk! Item was changed: ----- Method: Spur32BitMemoryManager>>setIsGreyOf:to: (in category 'header access') ----- setIsGreyOf: objOop to: aBoolean + + gc assertSettingGCFlagsIsOk: objOop. + self flag: #endianness. self longAt: objOop put: (aBoolean ifTrue: [(self longAt: objOop) bitOr: 1 << self greyBitShift] ifFalse: [(self longAt: objOop) bitAnd: (1 << self greyBitShift) bitInvert32])! Item was changed: ----- Method: Spur32BitMemoryManager>>setIsMarkedOf:to: (in category 'header access') ----- setIsMarkedOf: objOop to: aBoolean self assert: (self isFreeObject: objOop) not. + gc assertSettingGCFlagsIsOk: objOop. + self flag: #endianness. self longAt: objOop + 4 put: (aBoolean ifTrue: [(self longAt: objOop + 4) bitOr: 1 << self markedBitHalfShift] ifFalse: [(self longAt: objOop + 4) bitAnd: (1 << self markedBitHalfShift) bitInvert32])! Item was changed: ----- Method: Spur64BitMMLESimulator>>longAt:put: (in category 'memory access') ----- longAt: byteAddress put: a64BitValue "Store the 64-bit value at byteAddress which must be 0 mod 8." + "(self statScavenges >= 120 and: [byteAddress = 16rC7F770]) ifTrue: [self halt]." + "(self statScavenges >= 320 and: [byteAddress = 16r30DF6D0]) ifTrue: [self halt]." + "(self statScavenges >= 320 and: [a64BitValue = 16r30DF6D0]) ifTrue: [self halt]." + "byteAddress = 16r4A00408 ifTrue: [self halt]. + a64BitValue = 16r5A00408 ifTrue: [self halt]." - "byteAddress = 16r43C790 ifTrue: [self halt]." ^self long64At: byteAddress put: a64BitValue! Item was changed: ----- Method: Spur64BitMMLESimulator>>scavengingGCTenuringIf: (in category 'gc - global') ----- scavengingGCTenuringIf: tenuringCriterion "If we're /not/ a clone, clone the VM and push it over the cliff. If it survives, destroy the clone and continue. We should be OK until next time." + self setCheckForLeaks: GCModeFull. (self leakCheckNewSpaceGC and: [parent isNil]) ifTrue: [coInterpreter cr; print: 'scavenge '; print: statScavenges; tab; flush. CloneOnScavenge ifTrue: [coInterpreter cloneSimulation objectMemory scavengingGCTenuringIf: tenuringCriterion. Smalltalk garbageCollect]]. ^super scavengingGCTenuringIf: tenuringCriterion! Item was changed: ----- Method: Spur64BitMemoryManager>>allocateSlotsForPinningInOldSpace:bytes:format:classIndex: (in category 'allocation') ----- allocateSlotsForPinningInOldSpace: numSlots bytes: totalBytes format: formatField classIndex: classIndex "Answer the oop of a chunk of space in oldSpace with numSlots slots. Try and allocate in a segment that already includes pinned objects. The header of the result will have been filled-in but not the contents." <var: #totalBytes type: #usqInt> <inline: false> | chunk | chunk := self allocateOldSpaceChunkOfBytes: totalBytes suchThat: [:f| (segmentManager segmentContainingObj: f) containsPinned]. chunk ifNil: [chunk := self allocateOldSpaceChunkOfBytes: totalBytes. chunk ifNil: [^nil]. (segmentManager segmentContainingObj: chunk) containsPinned: true]. numSlots >= self numSlotsMask ifTrue: "for header parsing we put a saturated slot count in the prepended overflow size word" [self longAt: chunk put: numSlots + (self numSlotsMask << self numSlotsFullShift). self longAt: chunk + self baseHeaderSize put: ((self headerForSlots: self numSlotsMask format: formatField classIndex: classIndex) bitOr: 1 << self pinnedBitShift). self flag: #Todo. "later on we probably want to do this in the call above" + gc maybeModifyGCFlagsOf: chunk + self baseHeaderSize. - gc maybeModifyGCFlagsOf: chunk. self checkFreeSpace: GCModeNewSpace. ^chunk + self baseHeaderSize]. self longAt: chunk put: ((self headerForSlots: numSlots format: formatField classIndex: classIndex) bitOr: 1 << self pinnedBitShift). self flag: #Todo. "later on we probably want to do this in the call above" gc maybeModifyGCFlagsOf: chunk. self checkFreeSpace: GCModeNewSpace. ^chunk! Item was changed: ----- Method: Spur64BitMemoryManager>>allocateSlotsInOldSpace:bytes:format:classIndex: (in category 'allocation') ----- allocateSlotsInOldSpace: numSlots bytes: totalBytes format: formatField classIndex: classIndex "Answer the oop of a chunk of space in oldSpace with numSlots slots. The header will have been filled-in but not the contents. If no memory is available answer nil." <var: #totalBytes type: #usqInt> <inline: false> | chunk | chunk := self allocateOldSpaceChunkOfBytes: totalBytes. chunk ifNil: [^nil]. numSlots >= self numSlotsMask ifTrue: "for header parsing we put a saturated slot count in the prepended overflow size word" [self longAt: chunk put: numSlots + (self numSlotsMask << self numSlotsFullShift). self longAt: chunk + self baseHeaderSize put: (self headerForSlots: self numSlotsMask format: formatField classIndex: classIndex). self flag: #Todo. "later on we probably want to do this in the call above" + gc maybeModifyGCFlagsOf: chunk + self baseHeaderSize. - gc maybeModifyGCFlagsOf: chunk. self checkFreeSpace: GCModeNewSpace ignoring: chunk + self baseHeaderSize. ^chunk + self baseHeaderSize]. self longAt: chunk put: (self headerForSlots: numSlots format: formatField classIndex: classIndex). self flag: #Todo. "later on we probably want to do this in the call above" gc maybeModifyGCFlagsOf: chunk. self checkFreeSpace: GCModeNewSpace ignoring: chunk. ^chunk! Item was changed: ----- Method: Spur64BitMemoryManager>>setIsGreyOf:to: (in category 'header access') ----- setIsGreyOf: objOop to: aBoolean + + gc assertSettingGCFlagsIsOk: objOop. + self longAt: objOop put: (aBoolean ifTrue: [(self longAt: objOop) bitOr: 1 << self greyBitShift] ifFalse: [(self longAt: objOop) bitAnd: (1 << self greyBitShift) bitInvert64])! Item was changed: ----- Method: Spur64BitMemoryManager>>setIsMarkedOf:to: (in category 'header access') ----- setIsMarkedOf: objOop to: aBoolean self assert: (self isFreeObject: objOop) not. + gc assertSettingGCFlagsIsOk: objOop. self longAt: objOop put: (aBoolean ifTrue: [(self longAt: objOop) bitOr: 1 << self markedBitFullShift] ifFalse: [(self longAt: objOop) bitAnd: (1 << self markedBitFullShift) bitInvert64])! Item was added: + ----- Method: SpurGarbageCollector>>allocatorMarkBitToSet (in category 'as yet unclassified') ----- + allocatorMarkBitToSet + + ^ allocatorMarkBitToSet! Item was changed: ----- Method: SpurGarbageCollector>>allocatorShouldAllocateBlack (in category 'accessing') ----- allocatorShouldAllocateBlack + <cmacro: '() GIV(allocatorShouldAllocateBlack)'> - <inline: true> ^ allocatorShouldAllocateBlack! Item was added: + ----- Method: SpurGarbageCollector>>assertSettingGCFlagsIsOk: (in category 'as yet unclassified') ----- + assertSettingGCFlagsIsOk: objOop + + <doNotGenerate>! Item was added: + ----- Method: SpurGarbageCollector>>doScavengeWithoutIncrementalCollect: (in category 'scavenge') ----- + doScavengeWithoutIncrementalCollect: tenuringCriterion + "The inner shell for scavenge, abstrascted out so globalGarbageCollect can use it." + <inline: false> + manager doAllocationAccountingForScavenge. + manager gcPhaseInProgress: ScavengeInProgress. + manager pastSpaceStart: (scavenger scavenge: tenuringCriterion). + self assert: (self + oop: manager pastSpaceStart + isGreaterThanOrEqualTo: scavenger pastSpace start + andLessThanOrEqualTo: scavenger pastSpace limit). + manager freeStart: scavenger eden start. + manager gcPhaseInProgress: 0. + manager resetAllocationAccountingAfterGC.! Item was changed: + ----- Method: SpurGarbageCollector>>initialize (in category 'nil') ----- - ----- Method: SpurGarbageCollector>>initialize (in category 'initialize-release') ----- initialize allocatorShouldAllocateBlack := false! Item was changed: ----- Method: SpurGenerationScavengerSimulator>>scavenge: (in category 'scavenger') ----- scavenge: tenuringCriterion manager bootstrapping ifFalse: + [coInterpreter transcript nextPutAll: 'scavenging('; print: manager statScavenges; nextPutAll: ')...'; cr; flush. - [coInterpreter transcript nextPutAll: 'scavenging('; print: manager statScavenges; nextPutAll: ')...'; flush. cameFrom ifNotNil: [cameFrom := Dictionary new]]. ^super scavenge: tenuringCriterion! Item was changed: ----- Method: SpurIncrementalCompactor>>assertNoSegmentBeingCompacted (in category 'testing') ----- assertNoSegmentBeingCompacted + "Assertion only - no segment is being claimed at this point. All being compacted bits get cleared during sweeping when setting the occupation of the segments" - "Assertion only - no segment is being claimed at this point" | segInfo | <var: 'segInfo' type: #'SpurSegmentInfo *'> 0 to: manager numSegments - 1 do: [:i| segInfo := self addressOf: (manager segmentManager segments at: i). self deny: (self isSegmentBeingCompacted: segInfo)].! 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 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. + + 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))]]. + - ["Copy the object in segmentToFill and replace it by a forwarder." - self assert: (manager isPinned: currentEntity) not. - bytesToCopy := manager bytesInBody: currentEntity. - 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. - segmentToFill := segmentToFill + 1. ^ fillStart! Item was added: + ----- Method: SpurIncrementalCompactor>>completeCompact (in category 'as yet unclassified') ----- + completeCompact + + | segInfo | + 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]]! 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. 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) - ^ currentSegment = manager numSegments - 1 ifTrue: [true] ifFalse: [false]]]. ^ true! Item was changed: ----- Method: SpurIncrementalCompactor>>findAndSetSegmentToFill (in category 'segment to fill') ----- findAndSetSegmentToFill | segInfo | <var: 'segInfo' type: #'SpurSegmentInfo *'> 0 to: manager numSegments - 1 do: [:i| segInfo := self addressOf: (manager segmentManager segments at: i). (self segmentIsEmpty: segInfo) ifTrue: [segmentToFill := segInfo. ^i]]. ^-1! Item was changed: ----- Method: SpurIncrementalCompactor>>findOrAllocateSegmentToFill (in category 'segment to fill') ----- findOrAllocateSegmentToFill "There was no compacted segments from past GC that we can directly re-use. We need either to find an empty segment or allocate a new one." | segIndex | + "segment was already set from freePastSegmentsAndSetSegmentToFill at the end of the last markingpass. No need to do something. " - self findAndSetSegmentToFill. segmentToFill ifNotNil: [^0]. + self findAndSetSegmentToFill. + segmentToFill ifNotNil: [self reserveSegmentToFill. ^0]. + "No empty segment. We need to allocate a new one" (manager growOldSpaceByAtLeast: manager growHeadroom) ifNil: ["failed to allocate"^0]. "We don't know which segment it is that we've just allocated... So we look for it... This is a bit dumb." segIndex := self findAndSetSegmentToFill. + self assert: segmentToFill ~~ nil. + self reserveSegmentToFill! - self assert: segmentToFill ~~ nil.! Item was changed: ----- Method: SpurIncrementalCompactor>>finishCompaction (in category 'incremental compaction') ----- finishCompaction self setFreeChunkOfCompactedIntoSegment. + self postCompactionAction. + self resetCompactor! - self postCompactionAction! 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 - [manager - initFreeChunkWithBytes: segInfo segSize - manager bridgeSize at: segInfo segStart. + segmentToFill + ifNil: [manager detachFreeObject: freeChunk. + segmentToFill := segInfo]]]! - segmentToFill ifNil: [segmentToFill := segInfo]]]! Item was changed: ----- Method: SpurIncrementalCompactor>>incrementalCompact (in category 'api') ----- incrementalCompact self initializeCompactionIfNecessary. + shouldCompact - self doIncrementalCompact ifTrue: [ + self doIncrementalCompact + ifTrue: [ + self finishCompaction. + ^ true]] + ifFalse: [^ true "nothing to compact => we are finished"]. - self finishCompaction. - ^ true]. ^ false! Item was changed: ----- 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 - isCompacting := true ! Item was changed: ----- Method: SpurIncrementalCompactor>>planCompactionAndReserveSpace (in category 'compaction planning') ----- planCompactionAndReserveSpace + shouldCompact := self computeSegmentsToCompact - shouldCompact := self computeSegmentsToCompact. - shouldCompact - ifTrue: [self reserveSegmentToFill] ! Item was changed: ----- Method: SpurIncrementalCompactor>>reserveSegmentToFill (in category 'segment access') ----- reserveSegmentToFill "remove the free space from the freeLists so the mutator cannot allocate in this segment" | freeChunk | self assert: segmentToFill notNil. + self assert: (self segmentIsEmpty: segmentToFill). freeChunk := manager objectStartingAt: segmentToFill segStart. - self assert: (self segmentIsEmpty: freeChunk). - manager detachFreeObject: freeChunk! Item was added: + ----- Method: SpurIncrementalCompactor>>resetCompactor (in category 'as yet unclassified') ----- + resetCompactor + + isCompacting := false. + shouldCompact := nil. + currentHeapPointer := nil. + currentSegment := 0! Item was added: + ----- Method: SpurIncrementalCompactor>>segmentToFill (in category 'as yet unclassified') ----- + segmentToFill + + ^ segmentToFill! Item was added: + ----- Method: SpurIncrementalGarbageCollector>>assertSettingGCFlagsIsOk: (in category 'as yet unclassified') ----- + assertSettingGCFlagsIsOk: objOop + + "do not color young objects. They have an extra state we do not want to change" + self assert: (manager isOldObject: objOop). + + "while sweeping: do not color objects behind the currently point the sweeper is at. This would infer with the next marking pass" + self assert: (self allocatorShouldAllocateBlack not or: [objOop >= self compactor currentSweepingEntity])! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>doIncrementalCollect (in category 'as yet unclassified') ----- doIncrementalCollect phase = InMarkingPhase ifTrue: [ marker incrementalMarkObjects ifTrue: [ + manager allPastSpaceObjectsDo: [:obj | self assert: (manager isWhite: obj)]. - "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. 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. ^ self] ifFalse: [manager runLeakCheckerFor: GCModeIncremental]]. phase = InSweepingPhase ifTrue: [ compactor incrementalSweep ifTrue: [ self allocatorShouldAllocateBlack: false. manager allOldSpaceObjectsDo: [:ea | self assert: (manager isWhite: ea) ]. "self assert: manager allObjectsUnmarked." phase := InCompactingPhase. ^ self]]. phase = InCompactingPhase ifTrue: [ compactor incrementalCompact 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" + self assert: manager validObjStacks. - self assert: self validObjStacks. + "we are not sweeping anymore => reset it" + allocatorShouldAllocateBlack := false. + compactor resetComponents. + manager shutDownGlobalIncrementalGC: true. + coInterpreter setGCMode: GCModeNewSpace. + self doScavengeWithoutIncrementalCollect: MarkOnTenure. - self doScavenge: MarkOnTenure. coInterpreter setGCMode: GCModeIncremental. marker completeMarkObjects. + compactor sweepAndCompact. - compactor compact. "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. + + manager setHeapSizeAtPreviousGC! - marker resolveAllForwarders! Item was changed: + ----- Method: SpurIncrementalGarbageCollector>>incrementalCollect (in category 'global') ----- - ----- Method: SpurIncrementalGarbageCollector>>incrementalCollect (in category 'as yet unclassified') ----- incrementalCollect + self flag: #Todo. "where to put this?" + manager statScavenges = 0 ifTrue: [manager makeAllObjectsWhite.]. self doIncrementalCollect. self assert: manager validObjStacks.! Item was changed: ----- Method: SpurIncrementalGarbageCollector>>maybeModifyGCFlagsOf: (in category 'as yet unclassified') ----- maybeModifyGCFlagsOf: objOop <inline: true> + ((manager isOldObject: objOop) and: [allocatorShouldAllocateBlack and: [objOop >= compactor currentSweepingEntity]]) - ((manager isOldObject: objOop) and: [allocatorShouldAllocateBlack and: [objOop < compactor currentSweepingEntity]]) ifTrue: [manager setIsMarkedOf: objOop to: true]! Item was added: + ----- Method: SpurIncrementalGarbageCollectorSimulator>>doIncrementalCollect (in category 'as yet unclassified') ----- + doIncrementalCollect + + | context | + manager statScavenges \\ 50 = 0 ifTrue: [GCEventLog reset]. + "(manager statScavenges > 218 and: [phase = InSweepingPhase]) ifTrue: [self halt]." + "manager statScavenges = 320 ifTrue: [self halt]." + + "pop mutator context" + context := GCEventLog instance popContext. + self assert: context kind = #mutator. + super doIncrementalCollect. + GCEventLog instance pushMutatorContext! Item was changed: ----- Method: SpurIncrementalMarker>>incrementalMark (in category 'marking - incremental') ----- incrementalMark "does one marking cycle. Breaks after a certain amount of slots is marked and the last object, that amount is crossed in, is completely scanned" | currentObj slotsLeft | "manager objStack: manager markStack do: [:index :page | Transcript showln: (manager fetchPointer: index ofObject: page)]. manager sizeOfObjStack: manager markStack" currentObj := manager popObjStack: manager markStack. "skip young objects. They get already scanned as they are part of the roots" [(currentObj notNil) and: [(manager isNonImmediate: currentObj) and: [manager isYoung: currentObj]]] whileTrue: [currentObj := manager popObjStack: manager markStack.]. currentObj ifNil: [^ true]. "there is nothing more on the stack and we are done" slotsLeft := SlotLimitPerPass. [ | slotNumber slotsToVisit startIndex | "after passing the limit we push the current index on the stack. Is the currentObj only an index? " (manager isImmediate: currentObj) ifTrue: [startIndex := manager integerValueOf: currentObj. currentObj := manager popObjStack: manager markStack.] ifFalse: [startIndex := 0. self markAndTraceClassOf: currentObj. "eager color the object black. Either it will get scanned completely and the color is correct or we have at least scanned some of the slots. In the second case the mutator could modify one of the slots of the object that already were scanned and we would could lose this object. Therefore color the object early to trigger the write barrier on writes. There will be some overhead (trigger the barrier always although only the already scanned slots are technically black) but it seems we need to do this for correctness" self blackenObject: currentObj]. slotNumber := manager numStrongSlotsOfInephemeral: currentObj. slotsToVisit := slotNumber - startIndex. slotsLeft - slotsToVisit < 0 ifTrue: [ self markFrom: startIndex nSlots: slotsLeft of: currentObj. "If we need to abort earlier we push the index and the currently scanned object on the marking stack. Otherwise it is not possible for immediates to be on the stack (they have no fields to be scanned) -> we can use the immediated to detect this pattern" (manager topOfObjStack: manager markStack) ~= currentObj ifTrue: [manager push: currentObj onObjStack: manager markStack]. manager push: (manager integerObjectOf: slotsLeft) onObjStack: manager markStack. "we need to abort early to not run into some extreme corner cases (giant objects) that would explode our mark time assumptions" ^ false] ifFalse: ["we can mark all" slotsLeft := slotsLeft - slotsToVisit. self markFrom: startIndex nSlots: slotsToVisit of: currentObj]. currentObj := manager popObjStack: manager markStack. [(currentObj notNil) and: [(manager isNonImmediate: currentObj) and: [manager isYoung: currentObj]]] whileTrue: [currentObj := manager popObjStack: manager markStack.]. "repeat while there still are objects" currentObj notNil] whileTrue. ^ true! Item was changed: ----- Method: SpurIncrementalMarker>>pushHiddenRootsReferencesOnMarkingStack (in category 'root-scanning') ----- pushHiddenRootsReferencesOnMarkingStack | classTablePageSize | self markAndTraceObjStack: manager markStack andContents: false. self markAndTraceObjStack: manager weaklingStack andContents: false. self markAndTraceObjStack: manager mournQueue andContents: true. + self markAndTraceObjStack: manager ephemeronStack andContents: false. - self markAndTraceObjStack: manager ephemeronStack andContents: true. classTablePageSize := manager numStrongSlotsOfInephemeral: manager classTableFirstPage. self markNSlots: classTablePageSize of: manager classTableFirstPage. self blackenObject: manager classTableFirstPage! Item was changed: ----- Method: SpurIncrementalMarker>>pushNewSpaceReferencesOnMarkingStack (in category 'root-scanning') ----- pushNewSpaceReferencesOnMarkingStack manager allNewSpaceObjectsDo: [:objOop | | format | - self flag: #Todo. "ephermorons" format := manager formatOf: objOop. + ((manager isNonImmediate: objOop) and: [(manager isPureBitsFormat: format) not]) - ((manager isNonImmediate: objOop) and: [(manager isPureBitsFormat: format) not and: [(manager isWeakFormat: 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]]]] - (self shoudlBeOnMarkingStack: objOop) - ifTrue: [self markAndShouldScan: objOop]]]] ! Item was changed: ----- Method: SpurIncrementalMarker>>resetMarkProgress (in category 'marking - global') ----- resetMarkProgress - manager shutDownGlobalIncrementalGC: true. - isCurrentlyMarking := false. marking := false. manager emptyObjStack: manager markStack. manager emptyObjStack: manager weaklingStack. manager emptyObjStack: manager ephemeronStack! Item was changed: ----- Method: SpurIncrementalMarker>>shoudlBeOnMarkingStack: (in category 'marking-stack') ----- shoudlBeOnMarkingStack: objOop <inline: true> self flag: #Todo. "should be not immediate and no bit array" + ^ (manager isNonImmediate: objOop) and: [(manager isOldObject: objOop) and: [manager isWhite: objOop]]! - ^ (manager isOldObject: objOop) and: [manager isWhite: objOop]! 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: anObject) not 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: [(manager isOldObject: anObject) and: [manager isMarked: anObject]]]) ifTrue: [self pushOnMarkingStackAndMakeGreyIfNecessary: value]! Item was added: + ----- Method: SpurIncrementalMarkerSimulation>>pushOnMarkingStackAndMakeGrey: (in category 'marking-stack') ----- + pushOnMarkingStackAndMakeGrey: obj + + super pushOnMarkingStackAndMakeGrey: obj + ! Item was changed: + ----- Method: SpurIncrementalMarkerSimulation>>writeBarrierFor:at:with: (in category 'barrier') ----- - ----- Method: SpurIncrementalMarkerSimulation>>writeBarrierFor:at:with: (in category 'as yet unclassified') ----- writeBarrierFor: anObject at: index with: value GCEventLog + contextToKeepOnEvent: #writeBarrier - inContext: #writeBarrier do: [super writeBarrierFor: anObject at: index with: value] ! Item was changed: ----- Method: SpurIncrementalSweepAndCompact>>compact (in category 'api - global') ----- compact <doNotGenerate> + compactor completeCompact! - compactor compact! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>resetComponents (in category 'api - global') ----- + resetComponents + + sweeper resetSweeper. + compactor resetCompactor! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>sweep (in category 'api - global') ----- + sweep + + <inline: true> + sweeper globalSweep! Item was added: + ----- Method: SpurIncrementalSweepAndCompact>>sweepAndCompact (in category 'api - global') ----- + sweepAndCompact + + self + sweep; + compact! Item was changed: SpurCompactor subclass: #SpurIncrementalSweeper + instanceVariableNames: 'currentSweepingEntity isCurrentlySweeping currentSegmentUsed currentSegmentUnused currentSegmentsIndex currentsCycleSeenObjectCount currentSegmentsBridge' - instanceVariableNames: 'currentSweepingEntity isCurrentlySweeping currentSegmentUsed currentSegmentUnused currentSegmentsIndex currentsCycleSeenObjectCount' classVariableNames: 'MaxObjectsToFree' poolDictionaries: '' category: 'VMMaker-SpurGarbageCollector'! Item was added: + ----- Method: SpurIncrementalSweeper>>advanceSegment (in category 'as yet unclassified') ----- + advanceSegment + + self setOccupationAtIndex: currentSegmentsIndex used: currentSegmentUsed unused: currentSegmentUnused. + + currentSegmentUsed := currentSegmentUnused := 0. + currentSegmentsIndex := currentSegmentsIndex + 1. + + currentSegmentsIndex < manager segmentManager numSegments + ifTrue: [currentSegmentsBridge := manager segmentManager bridgeAt: currentSegmentsIndex] + ! Item was 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). - self assert: (self canUseAsFreeSpace: true). 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]]). self canUseAsFreeSpace: next] whileTrue: [currentObj := next]. ^ 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 | - | bytes start next currentObj currentSegmentsBridge | self assert: (self canUseAsFreeSpace: objOop). start := manager startOfObject: objOop. currentObj := objOop. bytes := 0. - currentSegmentsBridge := manager segmentManager bridgeAt: currentSegmentsIndex. - [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 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]. - ifTrue: [ - self setOccupationAtIndex: currentSegmentsIndex used: currentSegmentUsed unused: currentSegmentUnused. - currentSegmentUsed := currentSegmentUnused := 0. - currentSegmentsIndex := currentSegmentsIndex + 1. - currentSegmentsIndex < manager segmentManager numSegments - ifTrue: [currentSegmentsBridge := manager segmentManager bridgeAt: currentSegmentsIndex]]. (self canUseAsFreeSpace: next) and: [currentsCycleSeenObjectCount < MaxObjectsToFree]] whileTrue: [currentObj := next]. ^ manager addFreeChunkWithBytes: bytes at: start! Item was added: + ----- Method: SpurIncrementalSweeper>>compactorsSegmentToFill (in category 'as yet unclassified') ----- + compactorsSegmentToFill + + "this is incredible^10 ugly but I see no much better way to access the info" + + ^ manager gc compactor compactor segmentToFill! Item was changed: ----- Method: SpurIncrementalSweeper>>currentSweepingEntity (in category 'accessing') ----- currentSweepingEntity + <cmacro: '() GIV(currentSweepingEntity)'> ^ currentSweepingEntity! Item was changed: ----- Method: SpurIncrementalSweeper>>doIncrementalSweeping (in category 'api - incremental') ----- doIncrementalSweeping + "Scan the heap for unmarked objects and free them. Coalescence " - "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 assert: currentSweepingEntity notNil. currentsCycleSeenObjectCount := 0. [self oop: currentSweepingEntity isLessThan: manager endOfMemory] whileTrue: + [ currentSweepingEntity = currentSegmentsBridge + ifTrue: [self advanceSegment] + ifFalse: [self sweepCurrentSweepingEntity]. + + currentSweepingEntity :=self nextSweepingEntity . + - [ | oldEntity | - (self canUseAsFreeSpace: currentSweepingEntity) - ifTrue: [currentSweepingEntity := self cautiousBulkFreeChunkFrom: currentSweepingEntity] - ifFalse: [self unmark: currentSweepingEntity. - currentSegmentUsed := currentSegmentUsed + (manager bytesInBody: currentSweepingEntity). - currentsCycleSeenObjectCount := currentsCycleSeenObjectCount + 1]. - - oldEntity := currentSweepingEntity. - currentSweepingEntity := manager objectAfter: currentSweepingEntity limit: manager endOfMemory. - self assert: oldEntity <= currentSweepingEntity. - self assert: currentSweepingEntity notNil. - currentsCycleSeenObjectCount >= MaxObjectsToFree ifTrue: [^ false]]. manager checkFreeSpace: GCModeIncremental. ^ true! Item was changed: ----- Method: SpurIncrementalSweeper>>finishSweeping (in category 'as yet unclassified') ----- finishSweeping + self resetSweeper. - isCurrentlySweeping := false. manager updateSweepEndUsecs! Item was changed: ----- 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 added: + ----- Method: SpurIncrementalSweeper>>nextSweepingEntity (in category 'as yet unclassified') ----- + nextSweepingEntity + + | nextEntity reservedSegmentsFreeChunk | + nextEntity := manager objectAfter: currentSweepingEntity limit: manager endOfMemory. + reservedSegmentsFreeChunk := self compactorsSegmentToFill ifNotNil: [manager objectStartingAt: self compactorsSegmentToFill segStart]. + + nextEntity = reservedSegmentsFreeChunk + ifTrue: [ + currentSegmentUnused := manager bytesInBody: reservedSegmentsFreeChunk. + nextEntity := manager objectAfter: nextEntity limit: manager endOfMemory]. + + ^ nextEntity! Item was added: + ----- Method: SpurIncrementalSweeper>>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 := nil + + ! Item was added: + ----- Method: SpurIncrementalSweeper>>sweepCurrentSweepingEntity (in category 'api - incremental') ----- + sweepCurrentSweepingEntity + + (self canUseAsFreeSpace: currentSweepingEntity) + ifTrue: [currentSweepingEntity := self cautiousBulkFreeChunkFrom: currentSweepingEntity] + ifFalse: [self unmarkAndUpdateStats]. + ! Item was added: + ----- Method: SpurIncrementalSweeper>>unmarkAndUpdateStats (in category 'api - incremental') ----- + unmarkAndUpdateStats + + self unmark: currentSweepingEntity. + + currentSegmentUsed := currentSegmentUsed + (manager bytesInBody: currentSweepingEntity). + currentsCycleSeenObjectCount := currentsCycleSeenObjectCount + 1 + ! Item was changed: ----- Method: SpurMemoryManager class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') ----- isNonArgumentImplicitReceiverVariableName: aString + ^#('self' 'coInterpreter' 'manager' 'scavenger' 'segmentManager' 'compactor' 'planningCompactor' 'selectiveCompactor' 'heapMap' 'marker' 'sweeper' 'gc') includes: aString! - ^#('self' 'coInterpreter' 'manager' 'scavenger' 'segmentManager' 'compactor' 'planningCompactor' 'selectiveCompactor' 'heapMap' 'marker' 'sweeper') includes: aString! Item was changed: ----- Method: SpurMemoryManager>>addToFreeTree:bytes: (in category 'free space') ----- addToFreeTree: freeChunk bytes: chunkBytes "Add freeChunk to the large free chunk tree. For the benefit of sortedFreeObject:, answer the treeNode it is added to, if it is added to the next list of a freeTreeNode, otherwise answer 0." | childBytes parent child | + self initFreeTreeChunk: freeChunk bytes: chunkBytes. - self assert: (self isFreeObject: freeChunk). - self assert: chunkBytes = (self bytesInBody: freeChunk). - self assert: chunkBytes >= (self numFreeLists * self allocationUnit). - self - storePointer: self freeChunkNextIndex ofFreeChunk: freeChunk withValue: 0; - storePointer: self freeChunkPrevIndex ofFreeChunk: freeChunk withValue: 0; - storePointer: self freeChunkParentIndex ofFreeChunk: freeChunk withValue: 0; - storePointer: self freeChunkSmallerIndex ofFreeChunk: freeChunk withValue: 0; - storePointer: self freeChunkLargerIndex ofFreeChunk: freeChunk withValue: 0. "Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks." parent := 0. child := freeLists at: 0. [child ~= 0] whileTrue: [childBytes := self bytesInBody: child. "check for overlap; could write this as self oop: (self objectAfter: freeChunk) isLessThanOrEqualTo: child... but that relies on headers being correct, etc. So keep it clumsy..." self assert: ((self oop: freeChunk + chunkBytes - self baseHeaderSize isLessThanOrEqualTo: child) or: [self oop: freeChunk isGreaterThanOrEqualTo: child + childBytes - self baseHeaderSize]). childBytes = chunkBytes ifTrue: "size match; add to list at node." [self setNextFreeChunkOf: freeChunk withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: child) isLilliputianSize: false. self setNextFreeChunkOf: child withValue: freeChunk isLilliputianSize: false. ^child]. "walk down the tree" parent := child. child := self fetchPointer: (childBytes > chunkBytes ifTrue: [self freeChunkSmallerIndex] ifFalse: [self freeChunkLargerIndex]) ofFreeChunk: child]. parent = 0 ifTrue: [self assert: (freeLists at: 0) = 0. freeLists at: 0 put: freeChunk. freeListsMask := freeListsMask bitOr: 1. ^0]. self assert: (freeListsMask anyMask: 1). "insert in tree" self storePointer: self freeChunkParentIndex ofFreeChunk: freeChunk withValue: parent. self storePointer: (childBytes > chunkBytes ifTrue: [self freeChunkSmallerIndex] ifFalse: [self freeChunkLargerIndex]) ofFreeChunk: parent withValue: freeChunk. ^0! Item was changed: ----- Method: SpurMemoryManager>>allInstancesOf: (in category 'primitive support') ----- allInstancesOf: aClass "Attempt to answer an array of all objects, excluding those that may be garbage collected as a side effect of allocating the result array. If no memory is available answer the number of instances as a SmallInteger. Since objects are at least 16 bytes big, and the largest SmallInteger covers 1/4 of the address space, the count can never overflow." | classIndex freeChunk ptr start limit count bytes | classIndex := self rawHashBitsOf: aClass. classIndex = 0 ifTrue: [freeChunk := self allocateSlots: 0 format: self arrayFormat classIndex: ClassArrayCompactIndex. ^freeChunk]. gc markObjectsForEnumerationPrimitives ifTrue: [marker markObjects: true]. "may not want to revive objects unnecessarily; but marking is sloooow." freeChunk := self allocateLargestFreeChunk. "N.B. Does /not/ update totalFreeOldSpace" start := freeChunk + self baseHeaderSize. limit := self addressAfter: freeChunk. (self isClassAtUniqueIndex: aClass) ifTrue: [self uniqueIndex: classIndex allInstancesInto: start limit: limit resultsInto: [:c :p| count := c. ptr := p]] ifFalse: [self ambiguousClass: aClass allInstancesInto: start limit: limit resultsInto: [:c :p| count := c. ptr := p]]. self assert: (self isEmptyObjStack: markStack). gc markObjectsForEnumerationPrimitives ifTrue: [self assert: self allObjectsUnmarked. self emptyObjStack: weaklingStack] ifFalse: [self assert: (self isEmptyObjStack: weaklingStack)]. (count > (ptr - start / self bytesPerOop) "not enough room" or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word" [self freeObject: freeChunk. ^self integerObjectOf: count]. count < self numSlotsMask ifTrue: [| smallObj | smallObj := self allocateSlots: count format: self arrayFormat classIndex: ClassArrayCompactIndex. 0 to: count - 1 do: [:i| self storePointerUnchecked: i ofObject: smallObj withValue: (self fetchPointer: i ofFreeChunk: freeChunk)]. self freeChunkWithBytes: (self bytesInBody: freeChunk) at: (self startOfObject: freeChunk). self beRootIfOld: smallObj. self checkFreeSpace: GCModeFull. ^smallObj]. bytes := self largeObjectBytesForSlots: count. start := self startOfObject: freeChunk. self freeChunkWithBytes: limit - start - bytes at: start + bytes. totalFreeOldSpace := totalFreeOldSpace - bytes. self rawOverflowSlotsOf: freeChunk put: count. self set: freeChunk classIndexTo: ClassArrayCompactIndex formatTo: self arrayFormat. + gc maybeModifyGCFlagsOf: freeChunk. self possibleRootStoreInto: freeChunk. self checkFreeSpace: GCModeFull. self runLeakCheckerFor: GCModeFull. ^freeChunk! Item was added: + ----- Method: SpurMemoryManager>>initFreeTreeChunk:bytes: (in category 'free space') ----- + initFreeTreeChunk: freeChunk bytes: chunkBytes + + self assert: (self isFreeObject: freeChunk). + self assert: chunkBytes = (self bytesInBody: freeChunk). + self assert: chunkBytes >= (self numFreeLists * self allocationUnit). + self + storePointer: self freeChunkNextIndex ofFreeChunk: freeChunk withValue: 0; + storePointer: self freeChunkPrevIndex ofFreeChunk: freeChunk withValue: 0; + storePointer: self freeChunkParentIndex ofFreeChunk: freeChunk withValue: 0; + storePointer: self freeChunkSmallerIndex ofFreeChunk: freeChunk withValue: 0; + storePointer: self freeChunkLargerIndex ofFreeChunk: freeChunk withValue: 0. + ! Item was changed: ----- Method: SpurMemoryManager>>markStack (in category 'spur bootstrap') ----- markStack + + <cmacro: '() GIV(markStack)'> ^markStack! 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 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: SpurMemoryManager>>storePointerImmutabilityCheck:ofObject:withValue: (in category 'object access') ----- storePointerImmutabilityCheck: fieldIndex ofObject: objOop withValue: valuePointer "Note must check here for stores of young objects into old ones." <inline: true> "Must be inlined for the normal send in cannotAssign:to:withIndex:" self cppIf: IMMUTABILITY ifTrue: [self deny: (self isImmediate: objOop). (self isImmutable: objOop) ifTrue: [^coInterpreter cannotAssign: valuePointer to: objOop withIndex: fieldIndex]]. + self storePointer: fieldIndex ofObject: objOop withValue: valuePointer! - self storePointer: fieldIndex ofObject: objOop withValue: valuePointer. - - self marker writeBarrierFor: objOop at: fieldIndex with: valuePointer! Item was changed: ----- Method: StackInterpreter>>eekcr (in category 'debug printing') ----- eekcr "For marking the end of a leak check print message" <api> <inline: #never> + self print: '\n'; flush. - self printf: '\n'. self cCode: '' inSmalltalk: [self halt]!

1 0

[OpenSmalltalk/opensmalltalk-vm] 561d57: Fix issue 651 with VMMaker.oscog-nice.3251
by Nicolas Cellier 25 Aug '22

25 Aug '22

Branch: refs/heads/Cog Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: 561d57da08901d946bda86a5660be16e7c441841 https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/561d57da08901d946b… Author: Nicolas Cellier <nicolas.cellier(a)sirehna.com> Date: 2022-08-25 (Thu, 25 Aug 2022) Changed paths: M src/plugins/BitBltPlugin/BitBltPlugin.c Log Message: ----------- Fix issue 651 with VMMaker.oscog-nice.3251 The rgbMul BitBlt operation now work in 1-bit deep forms, and is correctly rounded for any other depth. Note that the rgbMul might be used for pre-multiplying color channels in some anti-aliasing algorithms.<br> It's been used in Cuis for font rendering see this thread: http://forum.world.st/BitBlt-looking-for-rule-blitting-an-alpha-mask-consta… http://lists.squeakfoundation.org/pipermail/vm-dev/2009-June/002760.html

1 0

VM Maker: VMMaker.oscog-nice.3251.mcz
by commits＠source.squeak.org 25 Aug '22

25 Aug '22

Nicolas Cellier uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-nice.3251.mcz ==================== Summary ==================== Name: VMMaker.oscog-nice.3251 Author: nice Time: 25 August 2022, 6:09:00.826995 pm UUID: fad63ac4-33e9-944d-a688-a69c2b8f5b33 Ancestors: VMMaker.oscog-nice.3250 Implement a correctly rounded rgbMul BitBlt with the ideas developped here: https://github.com/OpenSmalltalk/opensmalltalk-vm/issues/651 Also provide rgbMul tests for all depths (1 2 4 8 16 32) (32 bits depth test = 8 bits depth test). =============== Diff against VMMaker.oscog-nice.3250 =============== 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]]]!

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