[squeak-dev] The Trunk: KernelTests-eem.376.mczcommits at source.squeak.org commits at source.squeak.orgWed Mar 11 20:15:33 UTC 2020
Eliot Miranda uploaded a new version of KernelTests to project The Trunk: http://source.squeak.org/trunk/KernelTests-eem.376.mcz ==================== Summary ==================== Name: KernelTests-eem.376 Author: eem Time: 11 March 2020, 1:15:31.498035 pm UUID: 250e07ee-5f92-4553-b861-7a5a66dbf08d Ancestors: KernelTests-nice.375 Add the tests in WriteBarrierTests to accompany Kernel-eem.1317 =============== Diff against KernelTests-nice.375 =============== Item was changed: SystemOrganization addCategory: #'KernelTests-Classes'! SystemOrganization addCategory: #'KernelTests-Methods'! SystemOrganization addCategory: #'KernelTests-Numbers'! SystemOrganization addCategory: #'KernelTests-Objects'! SystemOrganization addCategory: #'KernelTests-Processes'! + SystemOrganization addCategory: #'KernelTests-WriteBarrier'! Item was added: + Object subclass: #WriteBarrierAnotherStub + instanceVariableNames: 'var1 var2 var3 var4 var5 var6 var7 var8 var9 var10' + classVariableNames: '' + poolDictionaries: '' + category: 'KernelTests-WriteBarrier'! Item was added: + ----- Method: WriteBarrierAnotherStub>>var1 (in category 'accessing') ----- + var1 + ^ var1! Item was added: + ----- Method: WriteBarrierAnotherStub>>var10 (in category 'accessing') ----- + var10 + ^ var10! Item was added: + ----- Method: WriteBarrierAnotherStub>>var10: (in category 'accessing') ----- + var10: anObject + var10 := anObject! Item was added: + ----- Method: WriteBarrierAnotherStub>>var1: (in category 'accessing') ----- + var1: anObject + var1 := anObject! Item was added: + Object subclass: #WriteBarrierStub + instanceVariableNames: 'var1 var2 var3 var4 var5 var6 var7 var8 var9 var10' + classVariableNames: '' + poolDictionaries: '' + category: 'KernelTests-WriteBarrier'! Item was added: + ----- Method: WriteBarrierStub>>var1 (in category 'accessing') ----- + var1 + ^ var1! Item was added: + ----- Method: WriteBarrierStub>>var10 (in category 'accessing') ----- + var10 + ^ var10! Item was added: + ----- Method: WriteBarrierStub>>var10: (in category 'accessing') ----- + var10: anObject + var10 := anObject! Item was added: + ----- Method: WriteBarrierStub>>var1: (in category 'accessing') ----- + var1: anObject + var1 := anObject! Item was added: + TestCase subclass: #WriteBarrierTest + instanceVariableNames: '' + classVariableNames: 'ContextInstance' + poolDictionaries: '' + category: 'KernelTests-WriteBarrier'! + + !WriteBarrierTest commentStamp: '' prior: 0! + My tests ensure the ReadOnly property of objects work properly. + + #testMutateIVObject is a good start to understand what is going on. + + The VM needs to be compiled with -DIMMUTABILTY= true for those tests to work.! Item was added: + ----- Method: WriteBarrierTest class>>initialize (in category 'initialization') ----- + initialize + + ContextInstance := Context sender: nil receiver: self new method: self >> #alwaysWritableObjects arguments: #()! Item was added: + ----- Method: WriteBarrierTest>>alwaysReadOnlyObjects (in category 'guinea pigs') ----- + alwaysReadOnlyObjects + "Immediates are always immutable" + ^ { 1 }! Item was added: + ----- Method: WriteBarrierTest>>alwaysWritableObjects (in category 'guinea pigs') ----- + alwaysWritableObjects + "Objects that currently can't be immutable" + ^ { ContextInstance . + Processor . + Processor activeProcess }! Item was added: + ----- Method: WriteBarrierTest>>expectedFailures (in category 'expected failures') ----- + expectedFailures + Smalltalk supportsReadOnlyObjects ifFalse: + [^self class testSelectors]. + ^#( testMutateByteArrayUsingDoubleAtPut testMutateByteArrayUsingFloatAtPut ), + ((Smalltalk classNamed: #MirrorPrimitives) + ifNil: [#(testBasicProxyReadOnly testBasicProxyWritable testSetIsReadOnlySuccessProxy)] + ifNotNil: [#()])! Item was added: + ----- Method: WriteBarrierTest>>maybeReadOnlyObjects (in category 'guinea pigs') ----- + maybeReadOnlyObjects + "ByteObject, Variable object, fixed sized object" + ^ { { 1 . 2 . 3 } asByteArray . { 1 . 2 . 3 } . (MessageSend receiver: 1 selector: #+ argument: 2) }! Item was added: + ----- Method: WriteBarrierTest>>testBasicProxyReadOnly (in category 'tests - proxy') ----- + testBasicProxyReadOnly + self alwaysReadOnlyObjects do: [ :each | + self assert: (MirrorPrimitives isObjectReadOnly: each) equals: true ]! Item was added: + ----- Method: WriteBarrierTest>>testBasicProxyWritable (in category 'tests - proxy') ----- + testBasicProxyWritable + self alwaysWritableObjects , self maybeReadOnlyObjects do: [ :each | + self assert: (MirrorPrimitives isObjectReadOnly: each) equals: false ]! Item was added: + ----- Method: WriteBarrierTest>>testBasicReadOnly (in category 'tests - object') ----- + testBasicReadOnly + self alwaysReadOnlyObjects do: [ :each | + self assert: each isReadOnlyObject equals: true ]! Item was added: + ----- Method: WriteBarrierTest>>testBasicWritable (in category 'tests - object') ----- + testBasicWritable + self alwaysWritableObjects , self maybeReadOnlyObjects do: [ :each | + self assert: each isReadOnlyObject equals: false ]! Item was added: + ----- Method: WriteBarrierTest>>testMutateByteArrayUsingByteAtPut (in category 'tests - object') ----- + testMutateByteArrayUsingByteAtPut + | guineaPig | + guineaPig := ByteArray new: 5. + guineaPig beReadOnlyObject. + + self + should: [ guineaPig byteAt: 1 put: 12 ] + raise: ModificationForbidden. + + [ guineaPig byteAt: 1 put: 12 ] + on: ModificationForbidden + do: [:modification | + self assert: modification fieldIndex equals: 1. + modification object beWritableObject. + modification retryModification ]. + + self assert: guineaPig first equals: 12! Item was added: + ----- Method: WriteBarrierTest>>testMutateByteArrayUsingDoubleAtPut (in category 'tests - object') ----- + testMutateByteArrayUsingDoubleAtPut + | guineaPig | + guineaPig := ByteArray new: 8. + guineaPig beReadOnlyObject. + + self + should: [ guineaPig doubleAt: 1 put: (2 raisedTo: 65) asFloat ] + raise: ModificationForbidden. + + [ guineaPig doubleAt: 1 put: (2 raisedTo: 65) asFloat ] + on: ModificationForbidden + do: [:modification | + self assert: modification fieldIndex equals: 1. + modification object beWritableObject. + modification retryModification ]. + + self assert: guineaPig first equals: (2 raisedTo: 65) asFloat! Item was added: + ----- Method: WriteBarrierTest>>testMutateByteArrayUsingFloatAtPut (in category 'tests - object') ----- + testMutateByteArrayUsingFloatAtPut + | guineaPig | + guineaPig := ByteArray new: 5. + guineaPig beReadOnlyObject. + + self + should: [ guineaPig floatAt: 1 put: 1.0 ] + raise: ModificationForbidden. + + [ guineaPig floatAt: 1 put: 1.0 ] + on: ModificationForbidden + do: [:modification | + self assert: modification fieldIndex equals: 1. + modification object beWritableObject. + modification retryModification ]. + + self assert: guineaPig first equals: 1.0! Item was added: + ----- Method: WriteBarrierTest>>testMutateByteStringyUsingAtPut (in category 'tests - object') ----- + testMutateByteStringyUsingAtPut + | guineaPig | + guineaPig := ByteString new: 5. + guineaPig beReadOnlyObject. + + self + should: [ guineaPig at: 1 put: $h ] + raise: ModificationForbidden. + + [ guineaPig at: 1 put: $h ] + on: ModificationForbidden + do: [:modification | + self assert: modification fieldIndex equals: 1. + modification object beWritableObject. + modification retryModification ]. + + self assert: guineaPig first equals: $h! Item was added: + ----- Method: WriteBarrierTest>>testMutateByteStringyUsingByteAtPut (in category 'tests - object') ----- + testMutateByteStringyUsingByteAtPut + | guineaPig | + guineaPig := ByteString new: 5. + guineaPig beReadOnlyObject. + + self + should: [ guineaPig byteAt: 1 put: 100 ] + raise: ModificationForbidden. + + [ guineaPig byteAt: 1 put: 100 ] + on: ModificationForbidden + do: [:modification | + self assert: modification fieldIndex equals: 1. + modification object beWritableObject. + modification retryModification ]. + + self assert: guineaPig first asciiValue equals: 100! Item was added: + ----- Method: WriteBarrierTest>>testMutateByteSymbolUsingPrivateAtPut (in category 'tests - object') ----- + testMutateByteSymbolUsingPrivateAtPut + | guineaPig | + [guineaPig := #hello. + guineaPig beReadOnlyObject. + + self + should: ((guineaPig class includesSelector: #pvtAt:put:) + ifTrue: [[ guineaPig perform: #pvtAt:put: with: 1 with: $q ]] "Squeak refuses to compile non-self sends of pvt* selectors." + ifFalse: [[ guineaPig privateAt: 1 put: $q ]]) + raise: ModificationForbidden ] + ensure: + [ guineaPig beWritableObject ]. + + self assert: guineaPig first equals: $h! Item was added: + ----- Method: WriteBarrierTest>>testMutateIVObject (in category 'tests - object') ----- + testMutateIVObject + | guineaPig | + guineaPig := MessageSend new. + guineaPig beReadOnlyObject. + [ guineaPig receiver: 1 ] + on: ModificationForbidden + do: [ :modification | "Surely a NoModification error" ]. + guineaPig + beWritableObject; + selector: #+; + beReadOnlyObject. + [ guineaPig arguments: #(2) ] + on: ModificationForbidden + do: [ :modification |"Surely a NoModification error" ]. + self assert: guineaPig receiver isNil. + self assert: guineaPig arguments isNil. + self assert: guineaPig selector == #+.! Item was added: + ----- Method: WriteBarrierTest>>testMutateObjectClass (in category 'tests - object') ----- + testMutateObjectClass + | guineaPig | + guineaPig := WriteBarrierStub new. + guineaPig beReadOnlyObject. + + self + should: [ guineaPig primitiveChangeClassTo: WriteBarrierAnotherStub new ] + raise: ModificationForbidden. + + [ guineaPig primitiveChangeClassTo: WriteBarrierAnotherStub new ] + on: ModificationForbidden + do: [ :modification | + modification object beWritableObject. + modification retryModification ]. + + self assert: guineaPig class equals: WriteBarrierAnotherStub! Item was added: + ----- Method: WriteBarrierTest>>testMutateObjectClassViaAdoption (in category 'tests - object') ----- + testMutateObjectClassViaAdoption + | guineaPig | + guineaPig := WriteBarrierStub new. + guineaPig beReadOnlyObject. + + self + should: [ WriteBarrierAnotherStub adoptInstance: guineaPig ] + raise: ModificationForbidden. + + [ WriteBarrierAnotherStub adoptInstance: guineaPig ] + on: ModificationForbidden + do: [ :modification | + modification object beWritableObject. + modification retryModification ]. + + self assert: guineaPig class equals: WriteBarrierAnotherStub! Item was added: + ----- Method: WriteBarrierTest>>testMutateObjectFirstInstVarWithManyVars (in category 'tests - object') ----- + testMutateObjectFirstInstVarWithManyVars + | guineaPig failure | + guineaPig := WriteBarrierStub new. + guineaPig beReadOnlyObject. + failure := [ guineaPig var1: #test ] on: ModificationForbidden do: [:err | err]. + + self assert: failure fieldIndex equals: 1! Item was added: + ----- Method: WriteBarrierTest>>testMutateObjectInstVarShouldCatchRightFailure (in category 'tests - object') ----- + testMutateObjectInstVarShouldCatchRightFailure + | guineaPig failure | + guineaPig := MessageSend new. + guineaPig beReadOnlyObject. + failure := [ guineaPig receiver: #test ] on: ModificationForbidden do: [:err | err]. + + self assert: failure object == guineaPig. + self assert: failure newValue equals: #test. + self assert: failure fieldIndex equals: 1.! Item was added: + ----- Method: WriteBarrierTest>>testMutateObjectInstVarUsingAtPut (in category 'tests - object') ----- + testMutateObjectInstVarUsingAtPut + | guineaPig | + guineaPig := Array new: 5. + guineaPig beReadOnlyObject. + + self + should: [ guineaPig at: 1 put: #test ] + raise: ModificationForbidden. + + [ guineaPig at: 1 put: #test ] + on: ModificationForbidden + do: [:modification | + self assert: modification fieldIndex equals: 1. + modification object beWritableObject. + modification retryModification ]. + + self assert: guineaPig first equals: #test! Item was added: + ----- Method: WriteBarrierTest>>testMutateObjectInstVarUsingBasicAtPut (in category 'tests - object') ----- + testMutateObjectInstVarUsingBasicAtPut + | guineaPig | + guineaPig := Array new: 5. + guineaPig beReadOnlyObject. + + self + should: [ guineaPig basicAt: 1 put: #test ] + raise: ModificationForbidden. + + [ guineaPig at: 1 put: #test ] + on: ModificationForbidden + do: [:modification | + self assert: modification fieldIndex equals: 1. + modification object beWritableObject. + modification retryModification ]. + + self assert: guineaPig first equals: #test! Item was added: + ----- Method: WriteBarrierTest>>testMutateObjectInstVarUsingInstVarAtPut (in category 'tests - object') ----- + testMutateObjectInstVarUsingInstVarAtPut + | guineaPig | + guineaPig := WriteBarrierStub new. + guineaPig beReadOnlyObject. + + self + should: [ guineaPig instVarAt: 1 put: #test ] + raise: ModificationForbidden. + + [ guineaPig instVarAt: 1 put: #test ] + on: ModificationForbidden + do: [:modification | + self assert: modification fieldIndex equals: 1. + modification object beWritableObject. + modification retryModification ]. + + self assert: guineaPig var1 equals: #test! Item was added: + ----- Method: WriteBarrierTest>>testMutateObjectLastInstVarWithManyVars (in category 'tests - object') ----- + testMutateObjectLastInstVarWithManyVars + | guineaPig failure | + guineaPig := WriteBarrierStub new. + guineaPig beReadOnlyObject. + failure := [ guineaPig var10: #test ] on: ModificationForbidden do: [:err | err]. + + self assert: failure fieldIndex equals: 10! Item was added: + ----- Method: WriteBarrierTest>>testMutateVariableObject (in category 'tests - object') ----- + testMutateVariableObject + | guineaPigs | + guineaPigs := {#[1 2 3] . #(1 2 3) }. + guineaPigs do: [ :guineaPig | + guineaPig beReadOnlyObject. + [guineaPig at: 1 put: 4] + on: ModificationForbidden + do: [ "Surely a NoModification error" ]. + guineaPig + beWritableObject; + at: 2 put: 5; + beReadOnlyObject. + [guineaPig at: 3 put: 6] + on: ModificationForbidden + do: [ "Surely a NoModification error" ]. + self assert: guineaPig first = 1. + self assert: guineaPig second = 5. + self assert: guineaPig third = 3 ]! Item was added: + ----- Method: WriteBarrierTest>>testMutateWideStringUsingAtPut (in category 'tests - object') ----- + testMutateWideStringUsingAtPut + | guineaPig | + guineaPig := 'hello' asWideString. + guineaPig beReadOnlyObject. + + self + should: [ guineaPig at: 1 put: $q ] + raise: ModificationForbidden. + + [ guineaPig at: 1 put: $q ] + on: ModificationForbidden + do: [:modification | + self assert: modification fieldIndex equals: 1. + modification object beWritableObject. + modification retryModification ]. + + self assert: guineaPig first equals: $q! Item was added: + ----- Method: WriteBarrierTest>>testMutateWideStringUsingWordAtPut (in category 'tests - object') ----- + testMutateWideStringUsingWordAtPut + | guineaPig | + guineaPig := 'hello' asWideString. + guineaPig beReadOnlyObject. + + self + should: [ guineaPig wordAt: 1 put: 65536 ] + raise: ModificationForbidden. + + [ guineaPig wordAt: 1 put: 65536 ] + on: ModificationForbidden + do: [:modification | + self assert: modification fieldIndex equals: 1. + modification object beWritableObject. + modification retryModification ]. + + self assert: guineaPig first asciiValue equals: 65536! Item was added: + ----- Method: WriteBarrierTest>>testMutateWideSymbolUsingPrivateAtPut (in category 'tests - object') ----- + testMutateWideSymbolUsingPrivateAtPut + | guineaPig | + [ guineaPig := ('hello', (Character codePoint: 8002) asString) asSymbol. + guineaPig beReadOnlyObject. + + self + should: ((guineaPig class includesSelector: #pvtAt:put:) + ifTrue: [[ guineaPig perform: #pvtAt:put: with: 1 with: $A ]] "Squeak refuses to compile non-self sends of pvt* selectors." + ifFalse: [[ guineaPig privateAt: 1 put: $A ]]) + raise: ModificationForbidden ] + ensure: [ guineaPig beWritableObject ]. + + self assert: guineaPig first equals: $h! Item was added: + ----- Method: WriteBarrierTest>>testObject:initialState:tuples: (in category 'tests - helper') ----- + testObject: object initialState: initialState tuples: tuples + self + testObject: object + initialState: initialState + tuples: tuples + setReadOnlyBlock: [ :value | object setIsReadOnlyObject: value ]! Item was added: + ----- Method: WriteBarrierTest>>testObject:initialState:tuples:setReadOnlyBlock: (in category 'tests - helper') ----- + testObject: object initialState: initialState tuples: tuples setReadOnlyBlock: setImmutabilityBlock + self assert: object isReadOnlyObject equals: initialState. + tuples do: [ :tuple | + | stateToSet expectedResult expectedNewState | + stateToSet := tuple first. + expectedResult := tuple second. + expectedNewState := tuple last. + [self assert: (setImmutabilityBlock value: stateToSet) equals: expectedResult ] + on: ((Smalltalk classNamed: #PrimitiveFailed) ifNil: [Error]) + do: [ self assert: (self alwaysReadOnlyObjects , self alwaysWritableObjects includes: object) ]. + self assert: object isReadOnlyObject equals: expectedNewState ]! Item was added: + ----- Method: WriteBarrierTest>>testProxyObject:initialState:tuples: (in category 'tests - helper') ----- + testProxyObject: object initialState: initialState tuples: tuples + self + testObject: object + initialState: initialState + tuples: tuples + setReadOnlyBlock: [ :value | + MirrorPrimitives makeObject: object readOnly: value ]! Item was added: + ----- Method: WriteBarrierTest>>testRetryingInstVarModification (in category 'tests - object') ----- + testRetryingInstVarModification + | guineaPig | + guineaPig := MessageSend new. + guineaPig beReadOnlyObject. + + [ guineaPig receiver: 1 ] on: ModificationForbidden do: [:err | + guineaPig beWritableObject. + err retryModification ]. + + self assert: guineaPig receiver equals: 1! Item was added: + ----- Method: WriteBarrierTest>>testSetIsReadOnlyFailure (in category 'tests - object') ----- + testSetIsReadOnlyFailure + self alwaysWritableObjects do: [ :each | + self + testObject: each + initialState: false + tuples: #( (true false false) (false false false) ) ]! Item was added: + ----- Method: WriteBarrierTest>>testSetIsReadOnlyFailureProxy (in category 'tests - proxy') ----- + testSetIsReadOnlyFailureProxy + self alwaysWritableObjects do: [ :each | + self + testProxyObject: each + initialState: false + tuples: #( (true false false) (false false false) ) ]! Item was added: + ----- Method: WriteBarrierTest>>testSetIsReadOnlyImmediate (in category 'tests - object') ----- + testSetIsReadOnlyImmediate + self alwaysReadOnlyObjects do: [ :each | + self + testObject: each + initialState: true + tuples: #( (true true true) (false true true) ) ]! Item was added: + ----- Method: WriteBarrierTest>>testSetIsReadOnlyImmediateProxy (in category 'tests - proxy') ----- + testSetIsReadOnlyImmediateProxy + self alwaysReadOnlyObjects do: [ :each | + self + testProxyObject: each + initialState: true + tuples: #( (true true true) (false true true) ) ]! Item was added: + ----- Method: WriteBarrierTest>>testSetIsReadOnlySuccess (in category 'tests - object') ----- + testSetIsReadOnlySuccess + self maybeReadOnlyObjects do: [ :each | + self + testObject: each + initialState: false + tuples: #( (true false true) (false true false) ) ]! Item was added: + ----- Method: WriteBarrierTest>>testSetIsReadOnlySuccessProxy (in category 'tests - proxy') ----- + testSetIsReadOnlySuccessProxy + self maybeReadOnlyObjects do: [ :each | + self + testProxyObject: each + initialState: false + tuples: #( (true false true) (false true false) ) ]!
More information about the Squeak-dev mailing list |