SystemOrganization addCategory: #'Transactional-Model'! SystemOrganization addCategory: #'Transactional-Tests'! SystemOrganization addCategory: #'Transactional-Errors'! !String methodsFor: '*transactional' stamp: 'lr 5/9/2007 10:46'! asAtomicSelector ^ Symbol intern: self atomicPrefix , (self asSymbol isInfix ifTrue: [ self , self atomicInfix ] ifFalse: [ self ])! ! !String methodsFor: '*transactional' stamp: 'lr 5/9/2007 10:50'! asNormalSelector | selector | selector := self allButFirst: self atomicPrefix size. (selector endsWith: self atomicInfix) ifTrue: [ selector := selector allButLast: self atomicInfix size ]. ^ Symbol intern: selector! ! !String methodsFor: '*transactional' stamp: 'lr 5/9/2007 10:48'! atomicInfix ^ '__infix:'! ! !String methodsFor: '*transactional' stamp: 'lr 4/16/2007 09:48'! atomicPrefix ^ '__atomic__'! ! !String methodsFor: '*transactional' stamp: 'lr 4/16/2007 09:48'! isAtomicSelector ^ self beginsWith: self atomicPrefix! ! !String methodsFor: '*transactional-override' stamp: 'lr 5/10/2007 10:28'! numArgs | colons | self isEmpty ifTrue: [ ^ -1 ]. colons := self occurrencesOf: $:. self last = $: ifTrue: [ ^ colons ]. (colons = 0 and: [ self allSatisfy: [ :each | each isSpecial ] ]) ifTrue: [ ^ 1 ]. ^ colons = 0 ifTrue: [ 0 ] ifFalse: [ -1 ]! ! !BlockContext methodsFor: '*transactional' stamp: 'lr 5/9/2007 15:37'! atomic ^ ACTransaction within: self! ! !BlockContext methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 14:47'! tempAt: index "Refer to the comment in ContextPart|tempAt:." ^home at: index! ! !BlockContext methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 14:47'! tempAt: index put: value "Refer to the comment in ContextPart|tempAt:put:." ^home at: index put: value! ! !Behavior methodsFor: '*transactional' stamp: 'lr 5/9/2007 13:19'! atomicMethods ^ Array streamContents: [ :stream | self methodDictionary keysAndValuesDo: [ :key :value | key isAtomicSelector ifTrue: [ stream nextPut: value ] ] ]! ! !Behavior methodsFor: '*transactional' stamp: 'lr 5/9/2007 11:07'! flushAtomic self methodDictionary keys do: [ :each | each isAtomicSelector ifTrue: [ self methodDictionary removeKey: each ] ]! ! !Behavior methodsFor: '*transactional-override' stamp: 'lr 5/9/2007 11:05'! selectors "Answer a Set of all the message selectors specified in the receiver's method dictionary." ^ self methodDict keys reject: [ :each | each isAtomicSelector ]! ! !Behavior methodsFor: '*transactional-override' stamp: 'lr 5/9/2007 11:05'! selectorsAndMethodsDo: aBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysAndValuesDo: [ :selector :method | selector isAtomicSelector ifFalse: [ aBlock value: selector value: method ] ]! ! !Behavior methodsFor: '*transactional-override' stamp: 'lr 5/9/2007 11:06'! selectorsDo: selectorBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysDo: [ :selector | selector isAtomicSelector ifFalse: [ selectorBlock value: selector ] ]! ! !CompiledMethod methodsFor: '*transactional' stamp: 'lr 5/9/2007 10:37'! atomicMethod ^ ACCompiler atomicMethodFor: self! ! !RBMethodNode methodsFor: '*transactional' stamp: 'lr 5/6/2007 15:30'! beAtomic self propertyAt: #atomic put: true! ! !RBMethodNode methodsFor: '*transactional' stamp: 'lr 5/5/2007 19:39'! isAtomic ^ self propertyAt: #atomic ifAbsentPut: [ false ]! ! !RBMethodNode methodsFor: '*transactional' stamp: 'lr 5/7/2007 08:11'! primitive ^ primitiveNode ifNotNil: [ :node | node num ]! ! TestCase subclass: #ACTransactionalTest instanceVariableNames: 'value array' classVariableNames: 'Value' poolDictionaries: '' category: 'Transactional-Tests'! ACTransactionalTest subclass: #ACBasicTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Tests'! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:18'! testAccessor self assert: [ self value: true. self value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:18'! testAccessorRead self value: true. self assert: [ self value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:18'! testAccessorWrite [ self value: true ] atomic. self assert: self value! ! !ACBasicTest methodsFor: 'testing-basic' stamp: 'lr 5/9/2007 14:56'! testBasicContext self assert: [ thisContext home ] atomic == thisContext! ! !ACBasicTest methodsFor: 'testing-basic' stamp: 'lr 5/9/2007 11:18'! testBasicSelf self assert: [ self ] atomic == self! ! !ACBasicTest methodsFor: 'testing-basic' stamp: 'lr 5/9/2007 11:18'! testBasicSuper self assert: [ super ] atomic == self! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testGlobal self assert: [ GlobalValue := true. GlobalValue ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testGlobalRead GlobalValue := true. self assert: [ GlobalValue ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testGlobalWrite [ GlobalValue := true ] atomic. self assert: GlobalValue! ! !ACBasicTest methodsFor: 'testing-inlined' stamp: 'lr 5/9/2007 14:58'! testInlinedAndOr self assert: [ true and: [ true ] ] atomic. self deny: [ false and: [ true ] ] atomic. self deny: [ true and: [ false ] ] atomic. self deny: [ false and: [ false ] ] atomic. self assert: [ true or: [ true ] ] atomic. self assert: [ false or: [ true ] ] atomic. self assert: [ true or: [ false ] ] atomic. self deny: [ false and: [ false ] ] atomic! ! !ACBasicTest methodsFor: 'testing-inlined' stamp: 'lr 5/9/2007 14:58'! testInlinedArray self assert: [ { } ] atomic = #( ). self assert: [ { 1 } ] atomic = #( 1 ). self assert: [ { 1. 2 } ] atomic = #( 1 2 ). self assert: [ { 1. 2. 3 } ] atomic = #( 1 2 3 ). self assert: [ { 1. 2. 3. 4 } ] atomic = #( 1 2 3 4 ). self assert: [ { 1. 2. 3. 4. 5 } ] atomic = #( 1 2 3 4 5 ). self assert: [ { 1. 2. 3. 4. 5. 6 } ] atomic = #( 1 2 3 4 5 6 )! ! !ACBasicTest methodsFor: 'testing-inlined' stamp: 'lr 5/9/2007 14:58'! testInlinedIfNil self assert: [ nil ifNil: [ true ] ] atomic. self assert: [ 1 ifNotNil: [ true ] ] atomic! ! !ACBasicTest methodsFor: 'testing-inlined' stamp: 'lr 5/9/2007 14:58'! testInlinedIfTrue self assert: [ true ifTrue: [ true ] ] atomic. self assert: [ false ifFalse: [ true ] ] atomic. self assert: [ true ifTrue: [ true ] ifFalse: [ false ] ] atomic. self assert: [ false ifFalse: [ true ] ifTrue: [ false ] ] atomic! ! !ACBasicTest methodsFor: 'testing-inlined' stamp: 'lr 5/9/2007 11:42'! testInlinedToDo | x | x := 0. [ 1 to: 10 do: [ :i | x := x + i ] ] atomic. self assert: x = 55. x := 0. [ 1 to: 10 by: 2 do: [ :i | x := x + i ] ] atomic. self assert: x = 25 ! ! !ACBasicTest methodsFor: 'testing-inlined' stamp: 'lr 5/9/2007 15:14'! testInlinedWhile | i x | i := 1. x := 0. [ [ x := x + i. i := i + 1. i <= 10 ] whileTrue ] atomic. self assert: x = 55. i := 1. x := 0. [ [ i <= 10 ] whileTrue: [ x := x + i. i := i + 1 ] ] atomic. self assert: x = 55. i := 1. x := 0. [ [ x := x + i. i := i + 1. i > 10 ] whileFalse ] atomic. self assert: x = 55. i := 1. x := 0. [ [ i > 10 ] whileFalse: [ x := x + i. i := i + 1 ] ] atomic. self assert: x = 55! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testInstance self assert: [ value := true. value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testInstanceRead value := true. self assert: [ value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testInstanceWrite [ value := true ] atomic. self assert: value! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testLiteral self assert: [ Value := true. Value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testLiteralRead Value := true. self assert: [ Value ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testLiteralWrite [ Value := true ] atomic. self assert: Value! ! !ACBasicTest methodsFor: 'testing' stamp: 'lr 5/10/2007 09:48'! testLoop "This code showed some bug in the exception handling." | current | [ current := SortedCollection. [ current == nil ] whileFalse: [ current == Object ifTrue: [ ^ self ]. current := current superclass ] ] value. self assert: current == Object! ! !ACBasicTest methodsFor: 'testing-inlined' stamp: 'lr 5/10/2007 09:49'! testMinimal [ [ true & true ] whileTrue ] value! ! !ACBasicTest methodsFor: 'testing-sends' stamp: 'lr 5/9/2007 11:24'! testSendBinary self assert: [ 1 + 2 ] atomic = 3! ! !ACBasicTest methodsFor: 'testing-sends' stamp: 'lr 5/9/2007 11:24'! testSendKeyword self assert: [ 2 raisedTo: 3 ] atomic = 8! ! !ACBasicTest methodsFor: 'testing-sends' stamp: 'lr 5/9/2007 11:24'! testSendUnary self assert: [ 1 negated ] atomic = -1! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testTemp | temp | self assert: [ temp := true. temp ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testTempRead | temp | temp := true. self assert: [ temp ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testTempWrite | temp | [ temp := true ] atomic. self assert: temp! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testVariable self assert: [ array at: 1 put: true; at: 1 ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testVariableRead array at: 1 put: true. self assert: [ array at: 1 ] atomic! ! !ACBasicTest methodsFor: 'testing-kinds' stamp: 'lr 5/9/2007 11:19'! testVariableWrite [ array at: 1 put: true ] atomic. self assert: (array at: 1)! ! ACTransactionalTest subclass: #ACCollectionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Tests'! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:04'! testArrayLong | arr | arr := Array new: 10 withAll: 1. [ 3 to: 10 do: [ :each | arr at: each put: (arr at: each - 1) + (arr at: each - 2) ] ] atomic. 3 to: 10 do: [ :each | self assert: (arr at: each) - (arr at: each - 1) = (arr at: each - 2) ]! ! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:04'! testArrayShort | arr | arr := Array new: 10 withAll: 1. 3 to: 10 do: [ :each | [ arr at: each put: (arr at: each - 1) + (arr at: each - 2) ] atomic ]. 3 to: 10 do: [ :each | self assert: (arr at: each) - (arr at: each - 1) = (arr at: each - 2) ]! ! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:04'! testBagLong | bag | bag := Bag new. [ 1 to: 10 do: [ :each | bag add: each; add: each ] ] atomic. self assert: bag size = 20. 1 to: 10 do: [ :each | self assert: (bag occurrencesOf: each) = 2 ]! ! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:03'! testBagShort | bag | bag := Bag new. 1 to: 10 do: [ :each | [ bag add: each; add: each ] atomic ]. self assert: bag size = 20. 1 to: 10 do: [ :each | self assert: (bag occurrencesOf: each) = 2 ]! ! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:03'! testDictionaryLong | dict | dict := Dictionary new. [ 1 to: 10 do: [ :each | dict at: each put: each ] ] atomic. self assert: dict size = 10. 1 to: 10 do: [ :each | self assert: (dict at: each) = each ]! ! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:03'! testDictionaryShort | dict | dict := Dictionary new. 1 to: 10 do: [ :each | [ dict at: each put: each ] atomic ]. self assert: dict size = 10. 1 to: 10 do: [ :each | self assert: (dict at: each) = each ]! ! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:04'! testSetLong | set | set := Set new. [ 1 to: 10 do: [ :each | set add: each ] ] atomic. self assert: set size = 10. 1 to: 10 do: [ :each | self assert: (set includes: each) ]! ! !ACCollectionTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:03'! testSetShort | set | set := Set new. 1 to: 10 do: [ :each | [ set add: each ] atomic ]. self assert: set size = 10. 1 to: 10 do: [ :each | self assert: (set includes: each) ]! ! ACTransactionalTest subclass: #ACErrorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Tests'! !ACErrorTest methodsFor: 'testing' stamp: 'lr 5/4/2007 13:50'! testAccessor self should: [ [ self value: true. self assert: self value. 1 / 0 ] atomic ] raise: ZeroDivide. self assert: (array at: 1) isNil! ! !ACErrorTest methodsFor: 'testing' stamp: 'lr 5/4/2007 13:50'! testInst self should: [ [ value := true. self assert: value. 1 / 0 ] atomic ] raise: ZeroDivide. self assert: value isNil! ! !ACErrorTest methodsFor: 'testing' stamp: 'lr 5/4/2007 13:50'! testLiteral self should: [ [ Value := true. self assert: Value. 1 / 0 ] atomic ] raise: ZeroDivide. self assert: Value isNil! ! !ACErrorTest methodsFor: 'testing' stamp: 'lr 5/7/2007 14:36'! testTemp | temp | self should: [ [ temp := true. self assert: temp. 1 / 0 ] atomic ] raise: ZeroDivide. self assert: temp = true! ! !ACErrorTest methodsFor: 'testing' stamp: 'lr 5/4/2007 13:50'! testVar self should: [ [ array at: 1 put: true. self assert: (array at: 1). 1 / 0 ] atomic ] raise: ZeroDivide. self assert: (array at: 1) isNil! ! !ACTransactionalTest class methodsFor: 'initialization' stamp: 'lr 5/4/2007 14:37'! initialize self environment at: #GlobalValue put: nil! ! !ACTransactionalTest methodsFor: 'running' stamp: 'lr 5/4/2007 14:37'! setUp value := nil. array := Array new: 1. Value := nil. GlobalValue := nil! ! !ACTransactionalTest methodsFor: 'utilities' stamp: 'lr 5/3/2007 15:59'! start: anInteger processes: aBlock | semaphores | aBlock fixTemps. semaphores := (1 to: anInteger) collect: [ :each | Semaphore new ]. semaphores do: [ :each | [ aBlock value. each signal ] fixTemps fork ]. semaphores do: [ :each | each wait ]! ! !ACTransactionalTest methodsFor: 'accessing' stamp: 'lr 5/3/2007 15:59'! value ^ value! ! !ACTransactionalTest methodsFor: 'accessing' stamp: 'lr 5/3/2007 15:59'! value: anObject value := anObject! ! TestCase subclass: #ACUtilitiesTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Tests'! !ACUtilitiesTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:48'! testAsAtomicSelector self assert: #string asAtomicSelector == #'__atomic__string'. self assert: #linesDo: asAtomicSelector == #'__atomic__linesDo:'. self assert: #indexOf:startingAt: asAtomicSelector == #'__atomic__indexOf:startingAt:'. self assert: #// asAtomicSelector == #'__atomic__//__infix:'! ! !ACUtilitiesTest methodsFor: 'testing' stamp: 'lr 5/9/2007 11:18'! testAsNormalSelector self assert: #'__atomic__string' asNormalSelector == #string. self assert: #'__atomic__linesDo:' asNormalSelector == #linesDo:. self assert: #'__atomic__indexOf:startingAt:' asNormalSelector == #indexOf:startingAt:. self assert: #'__atomic__//__infix:' asNormalSelector == #//! ! !ACUtilitiesTest methodsFor: 'testing' stamp: 'lr 5/9/2007 10:29'! testIsAtomicSelector self deny: #string isAtomicSelector. self deny: #linesDo: isAtomicSelector. self deny: #indexOf:startingAt: isAtomicSelector. self deny: #// isAtomicSelector. self assert: #'__atomic__string' isAtomicSelector. self assert: #'__atomic__linesDo:' isAtomicSelector. self assert: #'__atomic__indexOf:startingAt:' isAtomicSelector. self assert: #'__atomic__//:' isAtomicSelector! ! !ACUtilitiesTest methodsFor: 'testing' stamp: 'lr 5/10/2007 10:28'! testNumArgs self assert: #string numArgs = 0. self assert: #'__atomic__string' numArgs = 0. self assert: #linesDo: numArgs = 1. self assert: #'__atomic__linesDo:' numArgs = 1. self assert: #indexOf:startingAt: numArgs = 2. self assert: #'__atomic__indexOf:startingAt:' numArgs = 2. self assert: #// numArgs = 1. self assert: #'__atomic__//__infix:' numArgs = 1! ! Object subclass: #ACBenchmark instanceVariableNames: '' classVariableNames: 'Value' poolDictionaries: '' category: 'Transactional-Tests'! ACBenchmark class instanceVariableNames: 'value'! ACBenchmark class instanceVariableNames: 'value'! !ACBenchmark class methodsFor: 'utilities' stamp: 'lr 5/9/2007 10:16'! benchmark: aOriginalBlock reference: aReferenceBlock label: aString "Assert that aFastBlock is executed faster than aSlow block. The two blocks should be relatively fast and have no side effects, as they are executed multiple times." | originalCount originalTime referenceCount referenceTime factor | originalCount := referenceCount := 1. [ (originalTime := [ originalCount timesRepeat: aOriginalBlock ] timeToRun) < 500 ] whileTrue: [ originalCount := originalCount * 2 ]. [ (referenceTime := [ referenceCount timesRepeat: aReferenceBlock ] timeToRun) < 50 ] whileTrue: [ referenceCount := referenceCount * 2 ]. factor := ((originalTime * referenceCount) / (originalCount * referenceTime)) asFloat. Transcript show: aString; show: ': '; show: (factor roundTo: 0.001); cr! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/9/2007 10:19'! benchmarkActivation "self benchmarkActivation" self benchmark: [ [ ] atomic ] reference: [ [ ] value ] label: 'Activation'! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/9/2007 10:17'! benchmarkBinding "self benchmarkBinding" self benchmark: [ [ 100000 timesRepeat: [ Value ] ] atomic. [] value ] reference: [ [] atomic. [ 100000 timesRepeat: [ Value ] ] value ] label: 'Binding Read'. self benchmark: [ [ 100000 timesRepeat: [ Value := nil ] ] atomic. [] value ] reference: [ [] atomic. [ 100000 timesRepeat: [ Value := nil ] ] value ] label: 'Binding Write'.! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/9/2007 10:20'! benchmarkInstance "self benchmarkInstance" self benchmark: [ [ 100000 timesRepeat: [ value ] ] atomic. [] value ] reference: [ [] atomic. [ 100000 timesRepeat: [ value ] ] value ] label: 'Instance Read'. self benchmark: [ [ 100000 timesRepeat: [ value := nil ] ] atomic. [] value ] reference: [ [] atomic. [ 100000 timesRepeat: [ value := nil ] ] value ] label: 'Instance Write'! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/9/2007 10:19'! benchmarkSend "self benchmarkSend" self benchmark: [ [ 100000 timesRepeat: [ #( nil ) size ] ] atomic. [] value ] reference: [ [] atomic. [ 100000 timesRepeat: [ #( nil ) size ] ] value ] label: 'Send'! ! !ACBenchmark class methodsFor: 'benchmarks' stamp: 'lr 5/9/2007 10:20'! benchmarkVariable "self benchmarkVariable" self benchmark: [ [ 100000 timesRepeat: [ #( nil ) at: 1 ] ] atomic. [] value ] reference: [ [] atomic. [ 100000 timesRepeat: [ #( nil ) at: 1 ] ] value ] label: 'Variable Read'. self benchmark: [ [ 100000 timesRepeat: [ #( nil ) at: 1 put: nil ] ] atomic. [] value ] reference: [ [] atomic. [ 100000 timesRepeat: [ #( nil ) at: 1 put: nil ] ] value ] label: 'Variable Write'! ! Object subclass: #ACChange instanceVariableNames: 'transaction value previous' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Model'! !ACChange class methodsFor: 'instance-creation' stamp: 'lr 5/7/2007 11:29'! transaction: aTransaction ^ self new initializeWithTransaction: aTransaction! ! !ACChange methodsFor: 'actions' stamp: 'lr 4/27/2007 11:09'! apply self write: self value! ! !ACChange methodsFor: 'testing' stamp: 'lr 4/25/2007 13:33'! hasChanged ^ self previous ~~ self value! ! !ACChange methodsFor: 'testing' stamp: 'lr 4/25/2007 13:33'! hasConflict ^ self previous ~~ self read! ! !ACChange methodsFor: 'initialization' stamp: 'lr 5/7/2007 06:53'! initializeWithTransaction: aTransaction aTransaction changes add: self. transaction := aTransaction! ! !ACChange methodsFor: 'accessing' stamp: 'lr 4/25/2007 10:53'! previous ^ previous! ! !ACChange methodsFor: 'accessing' stamp: 'lr 4/25/2007 11:23'! previous: anObject previous := anObject! ! !ACChange methodsFor: 'printing' stamp: 'lr 5/4/2007 14:20'! printOn: aStream super printOn: aStream. " aStream nextPutAll: ' value: '; print: self value "! ! !ACChange methodsFor: 'utilities' stamp: 'lr 4/25/2007 10:57'! read "Read the value from the receiver." self subclassResponsibility! ! !ACChange methodsFor: 'actions' stamp: 'lr 4/25/2007 11:23'! update self value: self read. self previous: self value! ! !ACChange methodsFor: 'accessing' stamp: 'lr 4/23/2007 16:23'! value "Read the value local to the receivers transaction." ^ value! ! !ACChange methodsFor: 'accessing' stamp: 'lr 4/27/2007 10:46'! value: aValue "Write the value local to the receivers transaction." ^ value := aValue! ! !ACChange methodsFor: 'utilities' stamp: 'lr 4/25/2007 10:58'! write: anObject "Write anObject into the receiver." self subclassResponsibility! ! ACChange subclass: #ACGlobalChange instanceVariableNames: 'binding' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Model'! !ACGlobalChange class methodsFor: 'instance-creation' stamp: 'lr 5/7/2007 11:30'! binding: aBinding | transaction | transaction := ACTransaction current. ^ transaction globalChanges at: aBinding ifAbsentPut: [ (self transaction: transaction) binding: aBinding; update ]! ! !ACGlobalChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:22'! binding ^ binding! ! !ACGlobalChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:22'! binding: aBinding binding := aBinding! ! !ACGlobalChange methodsFor: 'utilities' stamp: 'lr 5/4/2007 18:23'! read ^ self binding value! ! !ACGlobalChange methodsFor: 'utilities' stamp: 'lr 5/4/2007 18:23'! write: anObject self binding value: anObject! ! ACChange subclass: #ACInstanceChange instanceVariableNames: 'object offset' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Model'! !ACInstanceChange class methodsFor: 'instance-creation' stamp: 'lr 5/7/2007 11:30'! object: anObject offset: anInteger | transaction slots change | transaction := ACTransaction current. slots := transaction instanceChanges at: anObject ifAbsentPut: [ Array new: anObject class instSize ]. change := slots at: anInteger. change ifNil: [ change := slots at: anInteger put: ((self transaction: transaction) object: anObject; offset: anInteger; update) ]. ^ change! ! !ACInstanceChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:25'! object ^ object! ! !ACInstanceChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:25'! object: anObject object := anObject! ! !ACInstanceChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:24'! offset ^ offset! ! !ACInstanceChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:24'! offset: anInteger offset := anInteger! ! !ACInstanceChange methodsFor: 'utilities' stamp: 'lr 5/4/2007 18:25'! read ^ self object instVarAt: self offset! ! !ACInstanceChange methodsFor: 'utilities' stamp: 'lr 5/4/2007 18:25'! write: anObject self object instVarAt: self offset put: anObject! ! ACChange subclass: #ACVariableChange instanceVariableNames: 'object offset' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Model'! !ACVariableChange class methodsFor: 'instance-creation' stamp: 'lr 5/7/2007 11:30'! object: anObject offset: anInteger | transaction slots change | transaction := ACTransaction current. slots := transaction instanceChanges at: anObject ifAbsentPut: [ Array new: anObject basicSize ]. change := slots at: anInteger. change ifNil: [ change := slots at: anInteger put: ((self transaction: transaction) object: anObject; offset: anInteger; update) ]. ^ change! ! !ACVariableChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:30'! object ^ object! ! !ACVariableChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:30'! object: anObject object := anObject! ! !ACVariableChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:21'! offset ^ offset! ! !ACVariableChange methodsFor: 'accessing' stamp: 'lr 5/4/2007 18:20'! offset: anInteger offset := anInteger! ! !ACVariableChange methodsFor: 'utilities' stamp: 'lr 5/7/2007 08:26'! read ^ self object basicAt: self offset! ! !ACVariableChange methodsFor: 'utilities' stamp: 'lr 5/7/2007 08:26'! write: anObject self object basicAt: self offset put: anObject! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:45'! at: index "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." index isInteger ifTrue: [self class isVariable ifTrue: [self errorSubscriptBounds: index] ifFalse: [self errorNotIndexable]]. index isNumber ifTrue: [^self at: index asInteger] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:45'! at: index put: value "Primitive. Assumes receiver is indexable. Store the argument value in the indexable element of the receiver indicated by index. Fail if the index is not an Integer or is out of bounds. Or fail if the value is not of the right type for this kind of collection. Answer the value that was stored. Essential. See Object documentation whatIsAPrimitive." index isInteger ifTrue: [self class isVariable ifTrue: [(index >= 1 and: [index <= self size]) ifTrue: [self errorImproperStore] ifFalse: [self errorSubscriptBounds: index]] ifFalse: [self errorNotIndexable]]. index isNumber ifTrue: [^self at: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: '*transactional' stamp: 'lr 5/7/2007 13:46'! atomicAt: anInteger ^ (ACVariableChange object: self offset: anInteger) value! ! !Object methodsFor: '*transactional' stamp: 'lr 5/7/2007 13:46'! atomicAt: anInteger put: anObject ^ (ACVariableChange object: self offset: anInteger) value: anObject! ! !Object methodsFor: '*transactional' stamp: 'lr 5/7/2007 06:32'! atomicInstVarAt: anInteger ^ (ACInstanceChange object: self offset: anInteger) value! ! !Object methodsFor: '*transactional' stamp: 'lr 5/7/2007 06:32'! atomicInstVarAt: anInteger put: anObject ^ (ACInstanceChange object: self offset: anInteger) value: anObject! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:45'! basicAt: index "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. Do not override in a subclass. See Object documentation whatIsAPrimitive." index isInteger ifTrue: [self errorSubscriptBounds: index]. index isNumber ifTrue: [^self basicAt: index asInteger] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:46'! basicAt: index put: value "Primitive. Assumes receiver is indexable. Store the second argument value in the indexable element of the receiver indicated by index. Fail if the index is not an Integer or is out of bounds. Or fail if the value is not of the right type for this kind of collection. Answer the value that was stored. Essential. Do not override in a subclass. See Object documentation whatIsAPrimitive." index isInteger ifTrue: [(index >= 1 and: [index <= self size]) ifTrue: [self errorImproperStore] ifFalse: [self errorSubscriptBounds: index]]. index isNumber ifTrue: [^self basicAt: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/9/2007 13:55'! doesNotUnderstand: aMessage "Handle the fact that there was an attempt to send the given message to the receiver but the receiver does not understand this message (typically sent from the machine when a message is sent to the receiver and no method is defined for that selector)." | selector class | aMessage selector isAtomicSelector ifTrue: [ selector := aMessage selector asNormalSelector. class := self class whichClassIncludesSelector: selector. Transcript show: class; space; show: selector; cr. self class methodDictionary at: aMessage selector put: (class >> selector) atomicMethod ] ifFalse: [ MessageNotUnderstood new message: aMessage; receiver: self; signal ]. ^ aMessage sentTo: self! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:47'! instVarAt: index "Primitive. Answer a fixed variable in an object. The numbering of the variables corresponds to the named instance variables. Fail if the index is not an Integer or is not the index of a fixed variable. Essential. See Object documentation whatIsAPrimitive." "Access beyond fixed variables." ^self basicAt: index - self class instSize ! ! !Object methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:47'! instVarAt: anInteger put: anObject "Primitive. Store a value into a fixed variable in the receiver. The numbering of the variables corresponds to the named instance variables. Fail if the index is not an Integer or is not the index of a fixed variable. Answer the value stored as the result. Using this message violates the principle that each object has sovereign control over the storing of values into its instance variables. Essential. See Object documentation whatIsAPrimitive." "Access beyond fixed fields" ^self basicAt: anInteger - self class instSize put: anObject! ! !LookupKey methodsFor: '*transactional' stamp: 'lr 5/7/2007 07:59'! atomicValue ^ (ACGlobalChange binding: self) value! ! !LookupKey methodsFor: '*transactional' stamp: 'lr 5/7/2007 07:59'! atomicValue: anObject ^ (ACGlobalChange binding: self) value: anObject! ! Error subclass: #ACConflict instanceVariableNames: 'changes' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Errors'! !ACConflict class methodsFor: 'instance-creation' stamp: 'lr 5/7/2007 07:16'! changes: aCollection ^ self new changes: aCollection; signal! ! !ACConflict methodsFor: 'accessing' stamp: 'lr 5/7/2007 07:16'! changes ^ changes! ! !ACConflict methodsFor: 'accessing' stamp: 'lr 5/7/2007 07:16'! changes: aCollection changes := aCollection! ! Error subclass: #ACInvalidTransaction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Errors'! Notification subclass: #ACCurrentTransaction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Transactional-Errors'! !ACCurrentTransaction class methodsFor: 'evaluating' stamp: 'lr 5/4/2007 17:46'! use: aTransaction during: aBlock ^ aBlock on: self do: [ :n | n resume: aTransaction ]! ! Object subclass: #ACTransaction instanceVariableNames: 'context changes globalChanges instanceChanges variableChanges' classVariableNames: '' poolDictionaries: 'ContextPart' category: 'Transactional-Model'! !ACTransaction class methodsFor: 'instance-creation' stamp: 'lr 5/7/2007 09:22'! current ^ ACCurrentTransaction signal! ! !ACTransaction class methodsFor: 'instance-creation' stamp: 'lr 5/7/2007 07:09'! within: aBlock ^ self new within: aBlock! ! !ACTransaction methodsFor: 'public' stamp: 'lr 5/7/2007 08:24'! abort changes := globalChanges := instanceChanges := variableChanges := nil! ! !ACTransaction methodsFor: 'private' stamp: 'lr 5/7/2007 07:35'! basicCommit | changed conflicts | changed := changes select: [ :each | each hasChanged ]. conflicts := changed select: [ :each | each hasConflict ]. conflicts isEmpty ifFalse: [ ACConflict changes: conflicts ]. changed do: [ :each | each apply ]! ! !ACTransaction methodsFor: 'public' stamp: 'lr 5/7/2007 08:24'! begin changes := OrderedCollection new. globalChanges := IdentityDictionary new. instanceChanges := IdentityDictionary new. variableChanges := IdentityDictionary new! ! !ACTransaction methodsFor: 'accessing' stamp: 'lr 5/7/2007 06:37'! changes ^ changes! ! !ACTransaction methodsFor: 'public' stamp: 'lr 5/7/2007 06:37'! commit [ self basicCommit ] valueUnpreemptively! ! !ACTransaction methodsFor: 'accessing' stamp: 'lr 5/7/2007 06:37'! context ^ context! ! !ACTransaction methodsFor: 'accessing-changes' stamp: 'lr 5/4/2007 18:32'! globalChanges ^ globalChanges! ! !ACTransaction methodsFor: 'accessing-changes' stamp: 'lr 5/4/2007 18:32'! instanceChanges ^ instanceChanges! ! !ACTransaction methodsFor: 'accessing-changes' stamp: 'lr 5/4/2007 18:32'! variableChanges ^ variableChanges! ! !ACTransaction methodsFor: 'public' stamp: 'lr 5/7/2007 15:16'! within: aBlock | result | self begin. [ result := ACCurrentTransaction use: self during: aBlock ] ifCurtailed: [ self abort ]. self commit. ^ result! ! !ContextPart methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:58'! canHandleSignal: exception "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then return true, otherwise forward this message to the next handler context. If none left, return false (see nil>>canHandleSignal:)" ^ (((self tempAt: 1) handles: exception) and: [self tempAt: 3]) or: [self nextHandlerContext canHandleSignal: exception]. ! ! !ContextPart methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 13:57'! handleSignal: exception "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then execute my handle block (second arg), otherwise forward this message to the next handler context. If none left, execute exception's defaultAction (see nil>>handleSignal:)." | val | (((self tempAt: 1) handles: exception) and: [self tempAt: 3]) ifFalse: [ ^ self nextHandlerContext handleSignal: exception]. exception privHandlerContext: self contextTag. self tempAt: 3 put: false. "disable self while executing handle block" val _ [(self tempAt: 2) valueWithPossibleArgs: {exception}] ensure: [self tempAt: 3 put: true]. self return: val. "return from self if not otherwise directed in handle block" ! ! !TraitBehavior methodsFor: '*transactional-override' stamp: 'lr 5/9/2007 11:05'! selectorsAndMethodsDo: aBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysAndValuesDo: [ :selector :method | selector isAtomicSelector ifFalse: [ aBlock value: selector value: method ] ]! ! !RBMessageNode methodsFor: '*transactional' stamp: 'lr 5/9/2007 14:50'! atomicSelector: aSelector | keywords numArgs | aSelector isAtomicSelector ifTrue: [ self error: 'Normal selector expected: ' , aSelector ]. selector := aSelector asAtomicSelector. keywords := aSelector keywords. numArgs := selector last = $: ifTrue: [ keywords size ] ifFalse: [ 0 ]. selectorParts := numArgs = 0 ifTrue: [ Array with: (RBIdentifierToken value: selector start: nil) ] ifFalse: [ keywords collect: [ :each | RBKeywordToken value: each start: nil ] ]! ! !BlockClosure methodsFor: '*transactional' stamp: 'lr 5/9/2007 15:36'! atomic ^ ACTransaction within: self! ! !ReflectiveMethod methodsFor: '*transactional' stamp: 'lr 5/9/2007 10:37'! atomicMethod ^ ACCompiler atomicMethodFor: self! ! !Exception methodsFor: '*transactional' stamp: 'lr 5/7/2007 13:56'! resumeUnchecked: resumptionValue "Return resumptionValue as the value of #signal, unless this was called after an #outer message, then return resumptionValue as the value of #outer." | ctxt | outerContext ifNil: [ signalContext return: resumptionValue ] ifNotNil: [ ctxt _ outerContext. outerContext _ ctxt tempAt: 1. "prevOuterContext in #outer" ctxt return: resumptionValue ]. ! ! !TPureBehavior methodsFor: '*transactional' stamp: 'lr 5/9/2007 13:19'! atomicMethods ^ Array streamContents: [ :stream | self methodDictionary keysAndValuesDo: [ :key :value | key isAtomicSelector ifTrue: [ stream nextPut: value ] ] ]! ! !TPureBehavior methodsFor: '*transactional' stamp: 'lr 5/9/2007 11:07'! flushAtomic self methodDictionary keys do: [ :each | each isAtomicSelector ifTrue: [ self methodDictionary removeKey: each ] ]! ! !TPureBehavior methodsFor: '*transactional-override' stamp: 'lr 5/9/2007 11:05'! selectors "Answer a Set of all the message selectors specified in the receiver's method dictionary." ^ self methodDict keys reject: [ :each | each isAtomicSelector ]! ! !TPureBehavior methodsFor: '*transactional-override' stamp: 'lr 5/9/2007 11:05'! selectorsAndMethodsDo: aBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysAndValuesDo: [ :selector :method | selector isAtomicSelector ifFalse: [ aBlock value: selector value: method ] ]! ! !TPureBehavior methodsFor: '*transactional-override' stamp: 'lr 5/9/2007 11:06'! selectorsDo: selectorBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysDo: [ :selector | selector isAtomicSelector ifFalse: [ selectorBlock value: selector ] ]! ! !MethodContext methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 14:46'! tempAt: index "Refer to the comment in ContextPart|tempAt:." ^self at: index! ! !MethodContext methodsFor: '*transactional-override' stamp: 'lr 5/7/2007 14:46'! tempAt: index put: value "Refer to the comment in ContextPart|tempAt:put:." ^self at: index put: value! ! PECompilerPlugin subclass: #ACCompiler instanceVariableNames: 'active' classVariableNames: 'Enabled' poolDictionaries: '' category: 'Transactional-Model'! !ACCompiler class methodsFor: 'accessing' stamp: 'lr 5/7/2007 13:54'! atomicMethodFor: aCompiledMethod "Answer the atomic counterpart of aCompiledMethod. Methods with the pragma #atomic are considered to be already atomic. Methods with the pragma #atomic: will use the annotation code for the atomic counterpart." | methodNode methodClass | methodNode := aCompiledMethod methodNode. methodNode pragmas do: [ :each | each pragma keyword = #atomic ifTrue: [ ^ aCompiledMethod compiledMethod ]. each pragma keyword = #atomic: ifTrue: [ methodClass := aCompiledMethod methodClass. methodNode := methodClass parserClass new parse: each pragma arguments first class: methodClass. ^ methodNode generate compiledMethod ] ]. ^ methodNode copy beAtomic generate compiledMethod! ! !ACCompiler class methodsFor: 'initialization' stamp: 'lr 5/10/2007 10:23'! initialize Enabled := true. SystemChangeNotifier uniqueInstance notify: self ofSystemChangesOfItem: #class change: #Modified using: #onClassChanged:; notify: self ofSystemChangesOfItem: #method change: #Added using: #onMethodChanged:; notify: self ofSystemChangesOfItem: #method change: #Modified using: #onMethodChanged:; notify: self ofSystemChangesOfItem: #method change: #Removed using: #onMethodChanged:! ! !ACCompiler class methodsFor: 'accessing' stamp: 'lr 5/9/2007 14:21'! isCompilerBackendPlugin ^ Enabled ifNil: [ Enabled := false ]! ! !ACCompiler class methodsFor: 'events' stamp: 'lr 5/9/2007 13:57'! onClassChanged: anObject self isCompilerBackendPlugin ifFalse: [ ^ self ]. anObject itemClass flushAtomic! ! !ACCompiler class methodsFor: 'events' stamp: 'lr 5/9/2007 14:00'! onMethodChanged: anObject self isCompilerBackendPlugin ifFalse: [ ^ self ]. anObject itemClass methodDict removeKey: anObject itemSelector asAtomicSelector ifAbsent: nil! ! !ACCompiler class methodsFor: 'accessing' stamp: 'lr 5/7/2007 07:02'! priority ^ GPTransformer priority - 1! ! !ACCompiler class methodsFor: 'initialization' stamp: 'lr 5/9/2007 12:09'! unload Enabled := false. SystemChangeNotifier uniqueInstance noMoreNotificationsFor: self. Smalltalk allClassesAndTraitsDo: [ :each | each flushAtomic. each class flushAtomic ]! ! !ACCompiler methodsFor: 'visiting-transform' stamp: 'lr 5/9/2007 15:39'! acceptAssignmentNode: aNode | gplink | self visitNode: aNode value. self isActive ifFalse: [ ^ self ]. gplink := GPLink new instead. aNode variable ifTemp: [ ^ self ] ifInstance: [ gplink metaObject: #object; selector: #atomicInstVarAt:put:; arguments: #(offset newValue) ] ifGlobal: [ gplink metaObject: #binding; selector: #atomicValue:; arguments: #(newValue) ]. aNode link: gplink! ! !ACCompiler methodsFor: 'visiting' stamp: 'lr 5/9/2007 15:38'! acceptBlockNode: aNode (self isActive or: [ aNode isInlined ]) ifTrue: [ ^ self visitNode: aNode body ]. (aNode parent notNil and: [ aNode parent isMessage and: [ aNode parent selector = #atomic ] ]) ifFalse: [ ^ self visitNode: aNode body ]. self active: true. [ self visitNode: aNode body ] ensure: [ self active: false ]! ! !ACCompiler methodsFor: 'visiting-transform' stamp: 'lr 5/9/2007 15:54'! acceptMessageNode: aNode super acceptMessageNode: aNode. self isActive ifFalse: [ ^ self ]. aNode isInline ifTrue: [ ^ self ]. aNode atomicSelector: aNode selector! ! !ACCompiler methodsFor: 'visiting' stamp: 'lr 5/9/2007 11:57'! acceptMethodNode: aNode self active: aNode isAtomic. self visitNode: aNode body! ! !ACCompiler methodsFor: 'visiting' stamp: 'lr 5/7/2007 06:49'! acceptSequenceNode: aNode aNode statements do: [ :each | self visitNode: each ]! ! !ACCompiler methodsFor: 'visiting-transform' stamp: 'lr 5/9/2007 14:52'! acceptVariableNode: aNode | gplink | self isActive ifFalse: [ ^ self ]. (self reservedNames includes: aNode name) ifTrue: [ ^ self ]. gplink := GPLink new instead. aNode ifTemp: [ ^ self ] ifInstance: [ gplink metaObject: #object; selector: #atomicInstVarAt:; arguments: #(offset) ] ifGlobal: [ gplink metaObject: #binding; selector: #atomicValue; arguments: #() ]. aNode link: gplink! ! !ACCompiler methodsFor: 'accessing' stamp: 'lr 5/9/2007 14:21'! active: aBoolean active := aBoolean! ! !ACCompiler methodsFor: 'testing' stamp: 'lr 5/7/2007 09:33'! isActive ^ active! ! !ACCompiler methodsFor: 'accessing' stamp: 'lr 5/9/2007 14:21'! reservedNames ^ #( 'self' 'super' 'thisContext' )! ! ACTransactionalTest initialize! ACCompiler initialize!