Vm-dev September 2014

vm-dev@lists.squeakfoundation.org

25 participants
90 discussions

VM Maker: Cog-eem.202.mcz
by commits＠source.squeak.org 05 Sep '14

05 Sep '14

Eliot Miranda uploaded a new version of Cog to project VM Maker: http://source.squeak.org/VMMaker/Cog-eem.202.mcz ==================== Summary ==================== Name: Cog-eem.202 Author: eem Time: 5 September 2014, 12:51:18.647 pm UUID: d0d65d71-4b3f-4969-964f-19e6b6c8bb83 Ancestors: Cog-eem.201 The 4.3 Spur bootstrap needs more stack space because of the class reshapings. Use ClassBuilder class>>beSilent: to lose the progress notification. Provide a category for computeMethodHeaderForNumArgs:numTemps:numLits:primitive: =============== Diff against Cog-eem.201 =============== Item was changed: ----- Method: SimulatorHarness>>interpreter:object:perform:withArguments: (in category 'bootstrap methods') ----- interpreter: sim object: receiver perform: selector withArguments: arguments "Interpret an expression in oldHeap using oldInterpreter. Answer the result." | fp savedpc savedsp savedStackPages result startByteCount | self assert: ({receiver. selector}, arguments allSatisfy: [:oop| oop isInteger and: [sim objectMemory addressCouldBeOop: oop]]). savedpc := sim localIP. savedsp := sim localSP. savedStackPages := Set with: sim stackPage. sim internalPush: receiver. arguments do: [:arg| sim internalPush: arg]. sim argumentCount: arguments size; messageSelector: selector. fp := sim localFP. startByteCount := sim byteCount. "sim byteCount = 66849 ifTrue: [self halt]." sim normalSend. sim incrementByteCount. "otherwise, send is not counted" ["sim printFrame: sim localFP WithSP: sim localSP" "sim setBreakSelector: #elementsForwardIdentityTo:" "sim byteCount = 66849 ifTrue: [self halt]." "(sim byteCount > 7508930 and: [sim localFP = -16r27894]) ifTrue: [self halt]." fp = sim localFP] whileFalse: [sim singleStep. (savedStackPages includes: sim stackPage) ifFalse: "If the stack gets deep something has probably gone wrong..." + [savedStackPages size > 20 ifTrue: [self halt]. - [savedStackPages size > 3 ifTrue: [self halt]. savedStackPages add: sim stackPage]]. result := sim internalPopStack. self assert: savedsp = sim localSP. self assert: sim localIP - 1 = savedpc. sim localIP: savedpc. ^result! Item was changed: ----- Method: SpurBootstrap class>>categoryForClass:meta:selector: (in category 'method prototype categorization') ----- categoryForClass: className meta: isMeta selector: selector ^(isMeta ifTrue: [{ className. #class. selector }] ifFalse: [{ className. selector }]) caseOf: { [#(Behavior allInstancesOrNil)] -> [#enumerating]. [#(Behavior byteSizeOfInstance)] -> [#'accessing instances and variables']. [#(Behavior byteSizeOfInstanceOfSize:)] -> [#'accessing instances and variables']. [#(Behavior elementSize)] -> [#'accessing instances and variables']. [#(Behavior handleFailingBasicNew)] -> [#private]. [#(Behavior handleFailingBasicNew:)] -> [#private]. [#(Behavior handleFailingFailingBasicNew)] -> [#private]. [#(Behavior handleFailingFailingBasicNew:)] -> [#private]. [#(Behavior identityHash)] -> [#comparing]. [#(Behavior isEphemeronClass)] -> [#testing]. [#(Behavior isImmediateClass)] -> [#testing]. [#(Character identityHash)] -> [#comparing]. [#(Class immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:)] -> [#'subclass creation']. [#(ClassBuilder superclass:immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:)] -> [#public]. [#(CompiledMethod class handleFailingFailingNewMethod:header:)] -> [#private]. [#(CompiledMethod class handleFailingNewMethod:header:)] -> [#private]. [#(Context class allInstances)] -> [#enumerating]. [#(Context class allInstancesDo:)] -> [#enumerating]. [#(Context failPrimitiveWith:)] -> [#'system simulation']. [#(Context isPrimFailToken:)] -> [#private]. [#(Context send:to:with:lookupIn:)] -> [#controlling]. [#(ContextPart isPrimFailToken:)] -> [#private]. [#(ContextPart send:to:with:lookupIn:)] -> [#controlling]. [#(CompiledMethod class headerFlagForEncoder:)] -> [#'method encoding']. [#(CompiledMethod class installPrimaryBytecodeSet:)] -> [#'class initialization']. [#(CompiledMethod class installSecondaryBytecodeSet:)] -> [#'class initialization']. + [#(EncoderForV3 computeMethodHeaderForNumArgs:numTemps:numLits:primitive:)] + -> [#'method encoding']. [#(EncoderForV3PlusClosures genCallPrimitive:)] -> [#'bytecode generation']. [#(EncoderForV3PlusClosures class callPrimitiveCode)] -> [#'bytecode decoding']. [#(MethodContext failPrimitiveWith:)] -> [#'system simulation']. [#(MethodContext class allInstances)] -> [#enumerating]. [#(MethodContext class allInstancesDo:)] -> [#enumerating]. [#(SmallInteger asCharacter)] -> [#converting]. [#(SmalltalkImage growMemoryByAtLeast:)] -> [#'memory space']. [#(SmalltalkImage maxIdentityHash)] -> [#'system attributes']. [#(SystemDictionary growMemoryByAtLeast:)] -> [#'memory space']. [#(SystemDictionary maxIdentityHash)] -> [#'system attributes']. [#(SystemDictionary setGCParameters)] -> [#'snapshot and quit']. [#(SystemNavigation allObjects)] -> [#query]. [#(SystemNavigation allObjectsOrNil)] -> [#query]. } otherwise: [Transcript nextPutAll: className. isMeta ifTrue: [Transcript nextPutAll: ' class']. Transcript nextPutAll: '>>'; store: selector; nextPutAll: ' is unclassified'; cr; flush. ^Categorizer default]! Item was changed: ----- Method: SpurBootstrap>>checkReshapeOf: (in category 'bootstrap image') ----- checkReshapeOf: ourMethodClasses "Check the shape of all our method classes match the shape of those in the image to be bootstrapped. Use the simulator to redefine any that need it. Does /not/ reshape metaclasses; these we assume are ok." | toReshape | toReshape := Set new. ourMethodClasses do: [:mc| (literalMap at: mc binding ifAbsent: []) ifNotNil: [:binding| (mc ~~ Character "Character will reshape anyway" and: [mc instSize ~= (oldHeap instanceSizeOf: (oldHeap fetchPointer: ValueIndex ofObject: binding))]) ifTrue: [toReshape add: mc]]]. toReshape isEmpty ifTrue: [^self]. + self interpreter: oldInterpreter + object: (self oldClassOopFor: ClassBuilder) + perform: (self findSymbol: #beSilent:) + withArguments: {oldHeap trueObject}. "Assume only one class in any subtree needs reshaping. Fast and loose but gets us there for now." toReshape copy do: [:class| toReshape removeAll: (toReshape select: [:ea| ea inheritsFrom: class])]. toReshape do: [:class| Transcript cr; nextPutAll: 'RESHAPING '; print: class; flush. self interpreter: oldInterpreter object: (self oldClassOopFor: Compiler) perform: (self findSymbol: #evaluate:) withArguments: {oldHeap stringForCString: class definition}]!

1 0

VM Maker: Cog-eem.201.mcz
by commits＠source.squeak.org 05 Sep '14

05 Sep '14

Eliot Miranda uploaded a new version of Cog to project VM Maker: http://source.squeak.org/VMMaker/Cog-eem.201.mcz ==================== Summary ==================== Name: Cog-eem.201 Author: eem Time: 5 September 2014, 11:17:41.073 am UUID: a07ebbf9-5b06-4572-84c0-0c41fdc56f07 Ancestors: Cog-eem.200 Add a Squeak 4.3 prototype for shouldBePrintedAsLiteral which brings that method up-to-date w.r.t. Squeak 4.5. =============== Diff against Cog-eem.200 =============== Item was added: + ----- Method: SpurBootstrap class>>CharacterPROTOTYPEshouldBePrintedAsLiteral (in category 'method prototypes squeak 4.3') ----- + CharacterPROTOTYPEshouldBePrintedAsLiteral + + ^(self asInteger between: 33 and: 255) and: [self asInteger ~= 127]!

1 0

[commit][3070] CogVM source as per VMMaker.oscog-eem.870
by commits＠squeakvm.org 05 Sep '14

05 Sep '14

Revision: 3070 Author: eliot Date: 2014-09-05 10:31:11 -0700 (Fri, 05 Sep 2014) Log Message: ----------- CogVM source as per VMMaker.oscog-eem.870 Fix bad regression in FilePlugin>>primitiveFileSetPosition introduces around r2797 that breaks > 1Gb file access. Change manifest files on Windows to make app HIGHDPIAWARE. Create a manifest for the consolevm and include it in the archive. Modified Paths: -------------- branches/Cog/build.win32x86/newspeak.cog.spur/Makefile branches/Cog/build.win32x86/newspeak.cog.spur/nsvm.exe.manifest branches/Cog/build.win32x86/newspeak.cog.v3/Makefile branches/Cog/build.win32x86/newspeak.cog.v3/nsvm.exe.manifest branches/Cog/build.win32x86/newspeak.stack.spur/Makefile branches/Cog/build.win32x86/newspeak.stack.spur/nsvm.exe.manifest branches/Cog/build.win32x86/newspeak.stack.v3/Makefile branches/Cog/build.win32x86/newspeak.stack.v3/nsvm.exe.manifest branches/Cog/build.win32x86/squeak.cog.spur/Croquet.exe.manifest branches/Cog/build.win32x86/squeak.cog.spur/Makefile branches/Cog/build.win32x86/squeak.cog.spur/Squeak.exe.manifest branches/Cog/build.win32x86/squeak.cog.v3/Croquet.exe.manifest branches/Cog/build.win32x86/squeak.cog.v3/Makefile branches/Cog/build.win32x86/squeak.cog.v3/Squeak.exe.manifest branches/Cog/build.win32x86/squeak.stack.spur/Croquet.exe.manifest branches/Cog/build.win32x86/squeak.stack.spur/Makefile branches/Cog/build.win32x86/squeak.stack.spur/Squeak.exe.manifest branches/Cog/build.win32x86/squeak.stack.v3/Croquet.exe.manifest branches/Cog/build.win32x86/squeak.stack.v3/Makefile branches/Cog/build.win32x86/squeak.stack.v3/Squeak.exe.manifest branches/Cog/nscogsrc/plugins/FilePlugin/FilePlugin.c branches/Cog/scripts/mkcogvmarchives branches/Cog/scripts/mksistaarchives branches/Cog/scripts/mkspurvmarchives branches/Cog/src/plugins/FilePlugin/FilePlugin.c Property Changed: ---------------- branches/Cog/platforms/Cross/vm/sqSCCSVersion.h Modified: branches/Cog/build.win32x86/newspeak.cog.spur/Makefile =================================================================== --- branches/Cog/build.win32x86/newspeak.cog.spur/Makefile 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/newspeak.cog.spur/Makefile 2014-09-05 17:31:11 UTC (rev 3070) @@ -317,6 +317,7 @@ $(VMRES): $(BASEDIR)/$(VM).rc $(RC) $(RCFLAGS) -i $(BASEDIR)/$(VM).rc -o $(OBJDIR)/$@ $(CP) $(VM).exe.manifest $(OBJDIR) + $(CP) $(VM).exe.manifest $(OBJDIR)/$(VM)Console.exe.manifest resource.o: $(VMRES) $(RC) $(RCFLAGS) -i $(OBJDIR)/$< -o $(OBJDIR)/$@ Modified: branches/Cog/build.win32x86/newspeak.cog.spur/nsvm.exe.manifest =================================================================== --- branches/Cog/build.win32x86/newspeak.cog.spur/nsvm.exe.manifest 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/newspeak.cog.spur/nsvm.exe.manifest 2014-09-05 17:31:11 UTC (rev 3070) @@ -1,12 +1,20 @@ <?xml version="1.0" encoding="UTF-8" standalone="yes"?> -<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> +<assembly + xmlns="urn:schemas-microsoft-com:asm.v1" + manifestVersion="1.0" + xmlns:asmv3="urn:schemas-microsoft-com:asm.v3"> <assemblyIdentity version="1.0.0.0" processorArchitecture="*" name="www.mirandabanda.org.Cog.Newspeak" type="win32" /> -<description>Newspeak Virtual Machine</description> +<description>Newspeak Smalltalk Virtual Machine</description> +<asmv3:application> + <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2011/WindowsSettings"> + <dpiAware>true</dpiAware> + </asmv3:windowsSettings> +</asmv3:application> <dependency> <dependentAssembly> <assemblyIdentity Modified: branches/Cog/build.win32x86/newspeak.cog.v3/Makefile =================================================================== --- branches/Cog/build.win32x86/newspeak.cog.v3/Makefile 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/newspeak.cog.v3/Makefile 2014-09-05 17:31:11 UTC (rev 3070) @@ -317,6 +317,7 @@ $(VMRES): $(BASEDIR)/$(VM).rc $(RC) $(RCFLAGS) -i $(BASEDIR)/$(VM).rc -o $(OBJDIR)/$@ $(CP) $(VM).exe.manifest $(OBJDIR) + $(CP) $(VM).exe.manifest $(OBJDIR)/$(VM)Console.exe.manifest resource.o: $(VMRES) $(RC) $(RCFLAGS) -i $(OBJDIR)/$< -o $(OBJDIR)/$@ Modified: branches/Cog/build.win32x86/newspeak.cog.v3/nsvm.exe.manifest =================================================================== --- branches/Cog/build.win32x86/newspeak.cog.v3/nsvm.exe.manifest 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/newspeak.cog.v3/nsvm.exe.manifest 2014-09-05 17:31:11 UTC (rev 3070) @@ -1,12 +1,20 @@ <?xml version="1.0" encoding="UTF-8" standalone="yes"?> -<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> +<assembly + xmlns="urn:schemas-microsoft-com:asm.v1" + manifestVersion="1.0" + xmlns:asmv3="urn:schemas-microsoft-com:asm.v3"> <assemblyIdentity version="1.0.0.0" processorArchitecture="*" name="www.mirandabanda.org.Cog.Newspeak" type="win32" /> -<description>Newspeak Virtual Machine</description> +<description>Newspeak Smalltalk Virtual Machine</description> +<asmv3:application> + <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2011/WindowsSettings"> + <dpiAware>true</dpiAware> + </asmv3:windowsSettings> +</asmv3:application> <dependency> <dependentAssembly> <assemblyIdentity Modified: branches/Cog/build.win32x86/newspeak.stack.spur/Makefile =================================================================== --- branches/Cog/build.win32x86/newspeak.stack.spur/Makefile 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/newspeak.stack.spur/Makefile 2014-09-05 17:31:11 UTC (rev 3070) @@ -318,6 +318,7 @@ $(VMRES): $(BASEDIR)/$(VM).rc $(RC) $(RCFLAGS) -i $(BASEDIR)/$(VM).rc -o $(OBJDIR)/$@ $(CP) $(VM).exe.manifest $(OBJDIR) + $(CP) $(VM).exe.manifest $(OBJDIR)/$(VM)Console.exe.manifest resource.o: $(VMRES) $(RC) $(RCFLAGS) -i $(OBJDIR)/$< -o $(OBJDIR)/$@ Modified: branches/Cog/build.win32x86/newspeak.stack.spur/nsvm.exe.manifest =================================================================== --- branches/Cog/build.win32x86/newspeak.stack.spur/nsvm.exe.manifest 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/newspeak.stack.spur/nsvm.exe.manifest 2014-09-05 17:31:11 UTC (rev 3070) @@ -1,12 +1,20 @@ <?xml version="1.0" encoding="UTF-8" standalone="yes"?> -<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> +<assembly + xmlns="urn:schemas-microsoft-com:asm.v1" + manifestVersion="1.0" + xmlns:asmv3="urn:schemas-microsoft-com:asm.v3"> <assemblyIdentity version="1.0.0.0" processorArchitecture="*" name="www.mirandabanda.org.Cog.Newspeak" type="win32" /> -<description>Newspeak Virtual Machine</description> +<description>Newspeak Smalltalk Virtual Machine</description> +<asmv3:application> + <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2011/WindowsSettings"> + <dpiAware>true</dpiAware> + </asmv3:windowsSettings> +</asmv3:application> <dependency> <dependentAssembly> <assemblyIdentity Modified: branches/Cog/build.win32x86/newspeak.stack.v3/Makefile =================================================================== --- branches/Cog/build.win32x86/newspeak.stack.v3/Makefile 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/newspeak.stack.v3/Makefile 2014-09-05 17:31:11 UTC (rev 3070) @@ -318,6 +318,7 @@ $(VMRES): $(BASEDIR)/$(VM).rc $(RC) $(RCFLAGS) -i $(BASEDIR)/$(VM).rc -o $(OBJDIR)/$@ $(CP) $(VM).exe.manifest $(OBJDIR) + $(CP) $(VM).exe.manifest $(OBJDIR)/$(VM)Console.exe.manifest resource.o: $(VMRES) $(RC) $(RCFLAGS) -i $(OBJDIR)/$< -o $(OBJDIR)/$@ Modified: branches/Cog/build.win32x86/newspeak.stack.v3/nsvm.exe.manifest =================================================================== --- branches/Cog/build.win32x86/newspeak.stack.v3/nsvm.exe.manifest 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/newspeak.stack.v3/nsvm.exe.manifest 2014-09-05 17:31:11 UTC (rev 3070) @@ -1,12 +1,20 @@ <?xml version="1.0" encoding="UTF-8" standalone="yes"?> -<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> +<assembly + xmlns="urn:schemas-microsoft-com:asm.v1" + manifestVersion="1.0" + xmlns:asmv3="urn:schemas-microsoft-com:asm.v3"> <assemblyIdentity version="1.0.0.0" processorArchitecture="*" name="www.mirandabanda.org.Cog.Newspeak" type="win32" /> -<description>Newspeak Virtual Machine</description> +<description>Newspeak Smalltalk Virtual Machine</description> +<asmv3:application> + <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2011/WindowsSettings"> + <dpiAware>true</dpiAware> + </asmv3:windowsSettings> +</asmv3:application> <dependency> <dependentAssembly> <assemblyIdentity Modified: branches/Cog/build.win32x86/squeak.cog.spur/Croquet.exe.manifest =================================================================== --- branches/Cog/build.win32x86/squeak.cog.spur/Croquet.exe.manifest 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/squeak.cog.spur/Croquet.exe.manifest 2014-09-05 17:31:11 UTC (rev 3070) @@ -1,5 +1,8 @@ <?xml version="1.0" encoding="UTF-8" standalone="yes"?> -<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> +<assembly + xmlns="urn:schemas-microsoft-com:asm.v1" + manifestVersion="1.0" + xmlns:asmv3="urn:schemas-microsoft-com:asm.v3"> <assemblyIdentity version="1.0.0.0" processorArchitecture="*" @@ -7,6 +10,11 @@ type="win32" /> <description>Croquet Smalltalk Virtual Machine</description> +<asmv3:application> + <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2011/WindowsSettings"> + <dpiAware>true</dpiAware> + </asmv3:windowsSettings> +</asmv3:application> <dependency> <dependentAssembly> <assemblyIdentity Modified: branches/Cog/build.win32x86/squeak.cog.spur/Makefile =================================================================== --- branches/Cog/build.win32x86/squeak.cog.spur/Makefile 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/squeak.cog.spur/Makefile 2014-09-05 17:31:11 UTC (rev 3070) @@ -328,6 +328,7 @@ $(VMRES): $(BASEDIR)/$(VM).rc $(RC) $(RCFLAGS) -i $(BASEDIR)/$(VM).rc -o $(OBJDIR)/$@ $(CP) $(VM).exe.manifest $(OBJDIR) + $(CP) $(VM).exe.manifest $(OBJDIR)/$(VM)Console.exe.manifest resource.o: $(VMRES) $(RC) $(RCFLAGS) -i $(OBJDIR)/$< -o $(OBJDIR)/$@ Modified: branches/Cog/build.win32x86/squeak.cog.spur/Squeak.exe.manifest =================================================================== --- branches/Cog/build.win32x86/squeak.cog.spur/Squeak.exe.manifest 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/squeak.cog.spur/Squeak.exe.manifest 2014-09-05 17:31:11 UTC (rev 3070) @@ -1,5 +1,8 @@ <?xml version="1.0" encoding="UTF-8" standalone="yes"?> -<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> +<assembly + xmlns="urn:schemas-microsoft-com:asm.v1" + manifestVersion="1.0" + xmlns:asmv3="urn:schemas-microsoft-com:asm.v3"> <assemblyIdentity version="1.0.0.0" processorArchitecture="*" @@ -7,6 +10,11 @@ type="win32" /> <description>Squeak Smalltalk Virtual Machine</description> +<asmv3:application> + <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2011/WindowsSettings"> + <dpiAware>true</dpiAware> + </asmv3:windowsSettings> +</asmv3:application> <dependency> <dependentAssembly> <assemblyIdentity Modified: branches/Cog/build.win32x86/squeak.cog.v3/Croquet.exe.manifest =================================================================== --- branches/Cog/build.win32x86/squeak.cog.v3/Croquet.exe.manifest 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/squeak.cog.v3/Croquet.exe.manifest 2014-09-05 17:31:11 UTC (rev 3070) @@ -1,5 +1,8 @@ <?xml version="1.0" encoding="UTF-8" standalone="yes"?> -<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> +<assembly + xmlns="urn:schemas-microsoft-com:asm.v1" + manifestVersion="1.0" + xmlns:asmv3="urn:schemas-microsoft-com:asm.v3"> <assemblyIdentity version="1.0.0.0" processorArchitecture="*" @@ -7,6 +10,11 @@ type="win32" /> <description>Croquet Smalltalk Virtual Machine</description> +<asmv3:application> + <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2011/WindowsSettings"> + <dpiAware>true</dpiAware> + </asmv3:windowsSettings> +</asmv3:application> <dependency> <dependentAssembly> <assemblyIdentity Modified: branches/Cog/build.win32x86/squeak.cog.v3/Makefile =================================================================== --- branches/Cog/build.win32x86/squeak.cog.v3/Makefile 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/squeak.cog.v3/Makefile 2014-09-05 17:31:11 UTC (rev 3070) @@ -367,6 +367,7 @@ $(VMRES): $(BASEDIR)/$(VM).rc $(RC) $(RCFLAGS) -i $(BASEDIR)/$(VM).rc -o $(OBJDIR)/$@ $(CP) $(VM).exe.manifest $(OBJDIR) + $(CP) $(VM).exe.manifest $(OBJDIR)/$(VM)Console.exe.manifest resource.o: $(VMRES) $(RC) $(RCFLAGS) -i $(OBJDIR)/$< -o $(OBJDIR)/$@ Modified: branches/Cog/build.win32x86/squeak.cog.v3/Squeak.exe.manifest =================================================================== --- branches/Cog/build.win32x86/squeak.cog.v3/Squeak.exe.manifest 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/squeak.cog.v3/Squeak.exe.manifest 2014-09-05 17:31:11 UTC (rev 3070) @@ -1,5 +1,8 @@ <?xml version="1.0" encoding="UTF-8" standalone="yes"?> -<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> +<assembly + xmlns="urn:schemas-microsoft-com:asm.v1" + manifestVersion="1.0" + xmlns:asmv3="urn:schemas-microsoft-com:asm.v3"> <assemblyIdentity version="1.0.0.0" processorArchitecture="*" @@ -7,6 +10,11 @@ type="win32" /> <description>Squeak Smalltalk Virtual Machine</description> +<asmv3:application> + <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2011/WindowsSettings"> + <dpiAware>true</dpiAware> + </asmv3:windowsSettings> +</asmv3:application> <dependency> <dependentAssembly> <assemblyIdentity Modified: branches/Cog/build.win32x86/squeak.stack.spur/Croquet.exe.manifest =================================================================== --- branches/Cog/build.win32x86/squeak.stack.spur/Croquet.exe.manifest 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/squeak.stack.spur/Croquet.exe.manifest 2014-09-05 17:31:11 UTC (rev 3070) @@ -1,5 +1,8 @@ <?xml version="1.0" encoding="UTF-8" standalone="yes"?> -<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> +<assembly + xmlns="urn:schemas-microsoft-com:asm.v1" + manifestVersion="1.0" + xmlns:asmv3="urn:schemas-microsoft-com:asm.v3"> <assemblyIdentity version="1.0.0.0" processorArchitecture="*" @@ -7,6 +10,11 @@ type="win32" /> <description>Croquet Smalltalk Virtual Machine</description> +<asmv3:application> + <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2011/WindowsSettings"> + <dpiAware>true</dpiAware> + </asmv3:windowsSettings> +</asmv3:application> <dependency> <dependentAssembly> <assemblyIdentity Modified: branches/Cog/build.win32x86/squeak.stack.spur/Makefile =================================================================== --- branches/Cog/build.win32x86/squeak.stack.spur/Makefile 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/squeak.stack.spur/Makefile 2014-09-05 17:31:11 UTC (rev 3070) @@ -329,6 +329,7 @@ $(VMRES): $(BASEDIR)/$(VM).rc $(RC) $(RCFLAGS) -i $(BASEDIR)/$(VM).rc -o $(OBJDIR)/$@ $(CP) $(VM).exe.manifest $(OBJDIR) + $(CP) $(VM).exe.manifest $(OBJDIR)/$(VM)Console.exe.manifest resource.o: $(VMRES) $(RC) $(RCFLAGS) -i $(OBJDIR)/$< -o $(OBJDIR)/$@ Modified: branches/Cog/build.win32x86/squeak.stack.spur/Squeak.exe.manifest =================================================================== --- branches/Cog/build.win32x86/squeak.stack.spur/Squeak.exe.manifest 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/squeak.stack.spur/Squeak.exe.manifest 2014-09-05 17:31:11 UTC (rev 3070) @@ -1,5 +1,8 @@ <?xml version="1.0" encoding="UTF-8" standalone="yes"?> -<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> +<assembly + xmlns="urn:schemas-microsoft-com:asm.v1" + manifestVersion="1.0" + xmlns:asmv3="urn:schemas-microsoft-com:asm.v3"> <assemblyIdentity version="1.0.0.0" processorArchitecture="*" @@ -7,6 +10,11 @@ type="win32" /> <description>Squeak Smalltalk Virtual Machine</description> +<asmv3:application> + <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2011/WindowsSettings"> + <dpiAware>true</dpiAware> + </asmv3:windowsSettings> +</asmv3:application> <dependency> <dependentAssembly> <assemblyIdentity Modified: branches/Cog/build.win32x86/squeak.stack.v3/Croquet.exe.manifest =================================================================== --- branches/Cog/build.win32x86/squeak.stack.v3/Croquet.exe.manifest 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/squeak.stack.v3/Croquet.exe.manifest 2014-09-05 17:31:11 UTC (rev 3070) @@ -1,5 +1,8 @@ <?xml version="1.0" encoding="UTF-8" standalone="yes"?> -<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> +<assembly + xmlns="urn:schemas-microsoft-com:asm.v1" + manifestVersion="1.0" + xmlns:asmv3="urn:schemas-microsoft-com:asm.v3"> <assemblyIdentity version="1.0.0.0" processorArchitecture="*" @@ -7,6 +10,11 @@ type="win32" /> <description>Croquet Smalltalk Virtual Machine</description> +<asmv3:application> + <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2011/WindowsSettings"> + <dpiAware>true</dpiAware> + </asmv3:windowsSettings> +</asmv3:application> <dependency> <dependentAssembly> <assemblyIdentity Modified: branches/Cog/build.win32x86/squeak.stack.v3/Makefile =================================================================== --- branches/Cog/build.win32x86/squeak.stack.v3/Makefile 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/squeak.stack.v3/Makefile 2014-09-05 17:31:11 UTC (rev 3070) @@ -329,6 +329,7 @@ $(VMRES): $(BASEDIR)/$(VM).rc $(RC) $(RCFLAGS) -i $(BASEDIR)/$(VM).rc -o $(OBJDIR)/$@ $(CP) $(VM).exe.manifest $(OBJDIR) + $(CP) $(VM).exe.manifest $(OBJDIR)/$(VM)Console.exe.manifest resource.o: $(VMRES) $(RC) $(RCFLAGS) -i $(OBJDIR)/$< -o $(OBJDIR)/$@ Modified: branches/Cog/build.win32x86/squeak.stack.v3/Squeak.exe.manifest =================================================================== --- branches/Cog/build.win32x86/squeak.stack.v3/Squeak.exe.manifest 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/build.win32x86/squeak.stack.v3/Squeak.exe.manifest 2014-09-05 17:31:11 UTC (rev 3070) @@ -1,5 +1,8 @@ <?xml version="1.0" encoding="UTF-8" standalone="yes"?> -<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> +<assembly + xmlns="urn:schemas-microsoft-com:asm.v1" + manifestVersion="1.0" + xmlns:asmv3="urn:schemas-microsoft-com:asm.v3"> <assemblyIdentity version="1.0.0.0" processorArchitecture="*" @@ -7,6 +10,11 @@ type="win32" /> <description>Squeak Smalltalk Virtual Machine</description> +<asmv3:application> + <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2011/WindowsSettings"> + <dpiAware>true</dpiAware> + </asmv3:windowsSettings> +</asmv3:application> <dependency> <dependentAssembly> <assemblyIdentity Modified: branches/Cog/nscogsrc/plugins/FilePlugin/FilePlugin.c =================================================================== --- branches/Cog/nscogsrc/plugins/FilePlugin/FilePlugin.c 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/nscogsrc/plugins/FilePlugin/FilePlugin.c 2014-09-05 17:31:11 UTC (rev 3070) @@ -1,9 +1,9 @@ /* Automatically generated by - VMPluginCodeGenerator VMMaker.oscog-eem.787 uuid: 4b38ebc1-339f-4523-a9fc-047923108211 + VMPluginCodeGenerator VMMaker.oscog-eem.870 uuid: aa732da6-bba7-4906-b822-6dfd7f4e1bc7 from - FilePlugin VMMaker.oscog-eem.787 uuid: 4b38ebc1-339f-4523-a9fc-047923108211 + FilePlugin VMMaker.oscog-eem.870 uuid: aa732da6-bba7-4906-b822-6dfd7f4e1bc7 */ -static char __buildInfo[] = "FilePlugin VMMaker.oscog-eem.787 uuid: 4b38ebc1-339f-4523-a9fc-047923108211 " __DATE__ ; +static char __buildInfo[] = "FilePlugin VMMaker.oscog-eem.870 uuid: aa732da6-bba7-4906-b822-6dfd7f4e1bc7 " __DATE__ ; @@ -180,9 +180,9 @@ struct VirtualMachine* interpreterProxy; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "FilePlugin VMMaker.oscog-eem.787 (i)" + "FilePlugin VMMaker.oscog-eem.870 (i)" #else - "FilePlugin VMMaker.oscog-eem.787 (e)" + "FilePlugin VMMaker.oscog-eem.870 (e)" #endif ; static void * sCCPfn; @@ -941,10 +941,8 @@ squeakFileOffsetType newPosition; sqInt objectPointer; - if (!(isIntegerObject(stackValue(0)))) { - if ((byteSizeOf(stackValue(0))) != (sizeof(squeakFileOffsetType))) { - return primitiveFail(); - } + if ((byteSizeOf(stackValue(0))) > (sizeof(squeakFileOffsetType))) { + return primitiveFail(); } newPosition = positive64BitValueOf(stackValue(0)); /* begin fileValueOf: */ Property changes on: branches/Cog/platforms/Cross/vm/sqSCCSVersion.h ___________________________________________________________________ Modified: checkindate - Tue Aug 26 09:49:41 BST 2014 + Fri Sep 5 10:18:14 PDT 2014 Modified: branches/Cog/scripts/mkcogvmarchives =================================================================== --- branches/Cog/scripts/mkcogvmarchives 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/scripts/mkcogvmarchives 2014-09-05 17:31:11 UTC (rev 3070) @@ -113,7 +113,8 @@ echo build.win32x86/$SQB/$1 '=>' $dir '=>' $dir-$TAG.zip (cd ../build.win32x86/$SQB/$1 >/dev/null; \ tar cf - Squeak.exe Squeak.map Squeak.exe.manifest \ - SqueakConsole.exe SqueakConsole.map *.dll) \ + SqueakConsole.exe SqueakConsole.map SqueakConsole.exe.manifest \ + *.dll) \ | (cd $dir;tar xf -) zip -qr $dir-$TAG.zip $dir EXES="$EXES $dir/Squeak.exe $dir/SqueakConsole.exe" Modified: branches/Cog/scripts/mksistaarchives =================================================================== --- branches/Cog/scripts/mksistaarchives 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/scripts/mksistaarchives 2014-09-05 17:31:11 UTC (rev 3070) @@ -134,7 +134,8 @@ echo build.win32x86/$SQSB/$1 '=>' $dir '=>' $dir-$TAG.zip (cd ../build.win32x86/$SQSB/$1 >/dev/null; \ tar cf - Squeak.exe Squeak.map Squeak.exe.manifest \ - SqueakConsole.exe SqueakConsole.map *.dll) \ + SqueakConsole.exe SqueakConsole.map SqueakConsole.exe.manifest \ + *.dll) \ | (cd $dir;tar xf -) zip -qr $dir-$TAG.zip $dir EXES="$EXES $dir/Squeak.exe $dir/SqueakConsole.exe" Modified: branches/Cog/scripts/mkspurvmarchives =================================================================== --- branches/Cog/scripts/mkspurvmarchives 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/scripts/mkspurvmarchives 2014-09-05 17:31:11 UTC (rev 3070) @@ -112,7 +112,8 @@ echo build.win32x86/$SQB/$1 '=>' $dir '=>' $dir-$TAG.zip (cd ../build.win32x86/$SQB/$1 >/dev/null; \ tar cf - Squeak.exe Squeak.map Squeak.exe.manifest \ - SqueakConsole.exe SqueakConsole.map *.dll) \ + SqueakConsole.exe SqueakConsole.map SqueakConsole.exe.manifest \ + *.dll) \ | (cd $dir;tar xf -) zip -qr $dir-$TAG.zip $dir EXES="$EXES $dir/Squeak.exe $dir/SqueakConsole.exe" Modified: branches/Cog/src/plugins/FilePlugin/FilePlugin.c =================================================================== --- branches/Cog/src/plugins/FilePlugin/FilePlugin.c 2014-08-28 14:14:21 UTC (rev 3069) +++ branches/Cog/src/plugins/FilePlugin/FilePlugin.c 2014-09-05 17:31:11 UTC (rev 3070) @@ -1,9 +1,9 @@ /* Automatically generated by - VMPluginCodeGenerator VMMaker.oscog-eem.787 uuid: 4b38ebc1-339f-4523-a9fc-047923108211 + VMPluginCodeGenerator VMMaker.oscog-eem.870 uuid: aa732da6-bba7-4906-b822-6dfd7f4e1bc7 from - FilePlugin VMMaker.oscog-eem.787 uuid: 4b38ebc1-339f-4523-a9fc-047923108211 + FilePlugin VMMaker.oscog-eem.870 uuid: aa732da6-bba7-4906-b822-6dfd7f4e1bc7 */ -static char __buildInfo[] = "FilePlugin VMMaker.oscog-eem.787 uuid: 4b38ebc1-339f-4523-a9fc-047923108211 " __DATE__ ; +static char __buildInfo[] = "FilePlugin VMMaker.oscog-eem.870 uuid: aa732da6-bba7-4906-b822-6dfd7f4e1bc7 " __DATE__ ; @@ -180,9 +180,9 @@ struct VirtualMachine* interpreterProxy; static const char *moduleName = #ifdef SQUEAK_BUILTIN_PLUGIN - "FilePlugin VMMaker.oscog-eem.787 (i)" + "FilePlugin VMMaker.oscog-eem.870 (i)" #else - "FilePlugin VMMaker.oscog-eem.787 (e)" + "FilePlugin VMMaker.oscog-eem.870 (e)" #endif ; static void * sCCPfn; @@ -941,10 +941,8 @@ squeakFileOffsetType newPosition; sqInt objectPointer; - if (!(isIntegerObject(stackValue(0)))) { - if ((byteSizeOf(stackValue(0))) != (sizeof(squeakFileOffsetType))) { - return primitiveFail(); - } + if ((byteSizeOf(stackValue(0))) > (sizeof(squeakFileOffsetType))) { + return primitiveFail(); } newPosition = positive64BitValueOf(stackValue(0)); /* begin fileValueOf: */

1 0

VM Maker: VMMaker.oscog-eem.870.mcz
by commits＠source.squeak.org 05 Sep '14

05 Sep '14

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.870.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.870 Author: eem Time: 5 September 2014, 10:05:12.358 am UUID: aa732da6-bba7-4906-b822-6dfd7f4e1bc7 Ancestors: VMMaker.oscog-eem.869 Fix bad regression in FilePlugin>>primitiveFileSetPosition that breaks > 1Gb file access. Trim printing of large literals in CogMethod disassembly. =============== Diff against VMMaker.oscog-eem.869 =============== Item was changed: ----- Method: CurrentImageCoInterpreterFacade>>lookupAddress: (in category 'labels') ----- lookupAddress: address | thing | thing := objectMap keyAtValue: address ifAbsent: [variables keyAtValue: address ifAbsent: [^nil]]. + ^(thing isLiteral - ^thing isLiteral ifTrue: [thing storeString] + ifFalse: [thing asString]) contractTo: 64! - ifFalse: [thing asString]! Item was changed: ----- Method: FilePlugin>>primitiveFileSetPosition (in category 'file primitives') ----- primitiveFileSetPosition | newPosition file | <var: 'file' type: 'SQFile *'> <var: 'newPosition' type: 'squeakFileOffsetType'> <export: true> + (interpreterProxy byteSizeOf: (interpreterProxy stackValue: 0)) > (self sizeof: #squeakFileOffsetType) ifTrue: + [^interpreterProxy primitiveFail]. - (interpreterProxy isIntegerObject: (interpreterProxy stackValue: 0)) ifFalse: - [(interpreterProxy byteSizeOf: (interpreterProxy stackValue: 0)) ~= (self sizeof: #squeakFileOffsetType) ifTrue: - [^interpreterProxy primitiveFail]]. newPosition := interpreterProxy positive64BitValueOf: (interpreterProxy stackValue: 0). file := self fileValueOf: (interpreterProxy stackValue: 1). interpreterProxy failed ifFalse: [self sqFile: file SetPosition: newPosition ]. interpreterProxy failed ifFalse: [interpreterProxy pop: 2] "pop position, file; leave rcvr on stack"!

1 0

Re: [squeak-dev] Re: large file support regression
by Eliot Miranda 05 Sep '14

05 Sep '14

Hi David, On Thu, Sep 4, 2014 at 4:10 PM, David T. Lewis <lewis(a)mail.msen.com> wrote: > On Thu, Sep 04, 2014 at 03:53:32PM -0700, Eliot Miranda wrote: > > On linux? What's the failure mode in your snippet? The position: > > primitive fails? > > > Probably a compile time option. For file addressing over 2GB, you need to > compile with -D_FILE_OFFSET_BITS=64. Possibly something changed in the > build > scripts? > No. Large file support has been enabled in the builds via -D_FILE_OFFSET_BITS=64 for a while now. I made a transcription error when eliminating the cCode: from sz := self cCode: 'sizeof(squeakFileOffsetType)'. (interpreterProxy byteSizeOf: (interpreterProxy stackValue: 0)) > sz ifTrue: [^interpreterProxy primitiveFail] I rewrote it as (interpreterProxy byteSizeOf: (interpreterProxy stackValue: 0)) ~= (self sizeof: #squeakFileOffsetType) ifTrue: [^interpreterProxy primitiveFail] instead of (interpreterProxy byteSizeOf: (interpreterProxy stackValue: 0)) > (self sizeof: #squeakFileOffsetType) ifTrue: [^interpreterProxy primitiveFail] doh. http://users.suse.com/~aj/linux_lfs.html > > In addition to Magma, this comes into play if you make a really big 64 bit > image, then try to save it. The image runs but cannot be saved unless the > VM was compiled with LFS support. > > Dave > > > > > > > > On Thu, Sep 4, 2014 at 3:36 PM, Chris Muller <asqueaker(a)gmail.com> > wrote: > > > > > Hi Eliot, it looks like any attempt to position a file beyond some > > > threshold is causing the primitive failure in Cog VM's released after > > > 2776 that I'm seeing. > > > > > > | file | file:=StandardFileStream newFileNamed: 'mybigfile'. file > binary. > > > [1234 timesRepeat: [ file nextPutAll: (ByteArray new: 1 million) ]. > > > file position: file size - 100 ] > > > ensure: [file close]. > > > > > > Magma uses a random file position for every single object retrieved; > > > so the performance of primitiveFileSetPosition is crucial to the > > > performance of Magma. > > > > > > Thanks. > > > > > > > > > > > -- > > best, > > Eliot > > > > > -- best, Eliot

1 0

Re: [Pharo-dev] PharoLauncher on Windows not the latest version
by Ben Coman 04 Sep '14

04 Sep '14

2 1

VM Maker: CogCompatibility-eem.1.mcz
by commits＠source.squeak.org 03 Sep '14

03 Sep '14

Eliot Miranda uploaded a new version of CogCompatibility to project VM Maker: http://source.squeak.org/VMMaker/CogCompatibility-eem.1.mcz ==================== Summary ==================== Name: CogCompatibility-eem.1 Author: eem Time: 3 September 2014, 10:05:54.273 am UUID: 57a99757-d07e-48a0-be92-14a76b6fe9ed Ancestors: Add a compatibility package for the Spur bootstrap. It contains Context, in which the Spur bootstrap needs to place prototypes for Pharo. Context could be installed in base Squeak at some point. This collapses MethodContext and ContextPart onto Context, given that the Cog closure implementation doesn't use BlockContext. ==================== Snapshot ==================== SystemOrganization addCategory: #'CogCompatibility-Pharo'! InstructionStream subclass: #Context instanceVariableNames: 'stackp method closureOrNil receiver' classVariableNames: 'MaxLengthForASingleDebugLogReport MaxStackDepthForASingleDebugLogReport PrimitiveFailToken QuickStep ValueIndex' poolDictionaries: '' category: 'CogCompatibility-Pharo'! !Context commentStamp: 'eem 9/2/2014 13:39' prior: 0! My instances hold all the dynamic state associated with the execution of either a method activation resulting from a message send or a block activation resulting from a block evaluation. In addition to their inherited state, this includes the receiver (self), the closure for a BlockClosure activation (which is nil for a method activation), a CompiledMethod, and space in the variable part of the context for arguments and temporary variables. Contexts, though normal in their variable size, are actually only used in two sizes, small and large, which are determined by the temporary space required by the method being executed. Contexts must only be created using the method newForMethod:. Note that it is impossible to determine the real object size of a Context except by asking for the frameSize of its method. Any fields above the stack pointer (stackp) are truly invisible -- even (and especially!!) to the garbage collector. Any store into stackp other than by the primitive method stackp: is potentially fatal. The simulator is a group of my methods that do what the Smalltalk interpreter does: execute Smalltalk bytecodes. By adding code to the simulator, you may take statistics on the running of Smalltalk methods. For example, Transcript show: (Context runSimulated: [3 factorial]) printString.! ----- Method: Context class>>allInstances (in category 'enumerating') ----- allInstances "Answer all instances of the receiver." <primitive: 177> "The primitive can fail because memory is low. If so, fall back on the old enumeration code, which gives the system a chance to GC and/or grow. Because aBlock might change the class of inst (for example, using become:), it is essential to compute next before aBlock value: inst. Only count until thisContext since this context has been created only to compute the existing instances." | inst insts next | insts := WriteStream on: (Array new: 64). inst := self someInstance. [inst == thisContext or: [inst == nil]] whileFalse: [next := inst nextInstance. insts nextPut: inst. inst := next]. ^insts contents! ----- Method: Context class>>allInstancesDo: (in category 'private') ----- allInstancesDo: aBlock "Evaluate aBlock with each of the current instances of the receiver." | instances inst next | instances := self allInstancesOrNil. instances ifNotNil: [instances do: aBlock. ^self]. "allInstancesOrNil can fail because memory is low. If so, fall back on the old enumeration code. Because aBlock might change the class of inst (for example, using become:), it is essential to compute next before aBlock value: inst. Only count until thisContext since evaluation of aBlock will create new contexts." inst := self someInstance. [inst == thisContext or: [inst == nil]] whileFalse: [next := inst nextInstance. aBlock value: inst. inst := next]! ----- Method: Context class>>basicNew: (in category 'instance creation') ----- basicNew: size ^ (size = CompiledMethod smallFrameSize or: [ size = CompiledMethod fullFrameSize ]) ifTrue: [ super basicNew: size ] ifFalse: [ self error: 'Contexts must be ' , CompiledMethod smallFrameSize , ' or ' , CompiledMethod fullFrameSize , ' bytes.' ]! ----- Method: Context class>>carefullyPrint:on: (in category 'private') ----- carefullyPrint: anObject on: aStream aStream nextPutAll: ([anObject printString] on: Error do: ['unprintable ' , anObject class name])! ----- Method: Context class>>contextEnsure: (in category 'special context creation') ----- contextEnsure: block "Create an #ensure: context that is ready to return from executing its receiver" | ctxt chain | ctxt := thisContext. [chain := thisContext sender cut: ctxt. ctxt jump] ensure: block. "jump above will resume here without unwinding chain" ^ chain! ----- Method: Context class>>contextOn:do: (in category 'special context creation') ----- contextOn: exceptionClass do: block "Create an #on:do: context that is ready to return from executing its receiver" | ctxt chain | ctxt := thisContext. [chain := thisContext sender cut: ctxt. ctxt jump] on: exceptionClass do: block. "jump above will resume here without unwinding chain" ^ chain! ----- Method: Context class>>initialize (in category 'class initialization') ----- initialize ValueIndex := 2. self assert: (Association instVarNameForIndex:ValueIndex) = 'value'. PrimitiveFailToken class ~~ Object ifTrue: [PrimitiveFailToken := Object new]! ----- Method: Context class>>initializedInstance (in category 'instance creation') ----- initializedInstance ^ nil! ----- Method: Context class>>isContextClass (in category 'private') ----- isContextClass ^true! ----- Method: Context class>>maxLengthForASingleDebugLogReport (in category 'preferences') ----- maxLengthForASingleDebugLogReport <preference: 'Max. Debug Report Length' category: 'debug' description: 'The description of an Exception stack will be truncated so as to not exceed this value' type: #Number> ^MaxLengthForASingleDebugLogReport ifNil: [40000]! ----- Method: Context class>>maxLengthForASingleDebugLogReport: (in category 'preferences') ----- maxLengthForASingleDebugLogReport: anInteger MaxLengthForASingleDebugLogReport := anInteger! ----- Method: Context class>>maxStackDepthForASingleDebugLogReport (in category 'preferences') ----- maxStackDepthForASingleDebugLogReport <preference: 'Max. Debug Report Stack Depth' category: 'debug' description: 'In an exception stack, any sender deeper than this value will not be logged.' type: #Number> ^MaxStackDepthForASingleDebugLogReport ifNil: [60]! ----- Method: Context class>>maxStackDepthForASingleDebugLogReport: (in category 'preferences') ----- maxStackDepthForASingleDebugLogReport: anInteger MaxStackDepthForASingleDebugLogReport := anInteger! ----- Method: Context class>>myEnvFieldIndex (in category 'closure support') ----- myEnvFieldIndex ^ self allInstVarNames indexOf: 'receiverMap'! ----- Method: Context class>>new (in category 'instance creation') ----- new self error: 'Contexts must only be created with newForMethod:'! ----- Method: Context class>>new: (in category 'instance creation') ----- new: size self error: 'Contexts must only be created with newForMethod:'! ----- Method: Context class>>newForMethod: (in category 'instance creation') ----- newForMethod: aMethod "This is the only method for creating new contexts, other than primitive cloning. Any other attempts, such as inherited methods like shallowCopy, should be avoided or must at least be rewritten to determine the proper size from the method being activated. This is because asking a context its size (even basicSize!!) will not return the real object size but only the number of fields currently accessible, as determined by stackp." ^ super basicNew: aMethod frameSize! ----- Method: Context class>>primitiveFailToken (in category 'simulation') ----- primitiveFailToken ^ PrimitiveFailToken! ----- Method: Context class>>primitiveFailTokenFor: (in category 'simulation') ----- primitiveFailTokenFor: errorCode ^{PrimitiveFailToken. errorCode}! ----- Method: Context class>>runSimulated: (in category 'simulation') ----- runSimulated: aBlock "Simulate the execution of the argument, current. Answer the result it returns." ^ thisContext sender runSimulated: aBlock contextAtEachStep: [:ignored] "ContextPart runSimulated: [Pen new defaultNib: 5; go: 100]"! ----- Method: Context class>>sender:receiver:method:arguments: (in category 'instance creation') ----- sender: s receiver: r method: m arguments: args "Answer an instance of me with attributes set to the arguments." ^(self newForMethod: m) setSender: s receiver: r method: m arguments: args! ----- Method: Context class>>tallyInstructions: (in category 'examples') ----- tallyInstructions: aBlock "This method uses the simulator to count the number of occurrences of each of the Smalltalk instructions executed during evaluation of aBlock. Results appear in order of the byteCode set." | tallies | tallies := Bag new. thisContext sender runSimulated: aBlock contextAtEachStep: [:current | tallies add: current nextByte]. ^tallies sortedElements "ContextPart tallyInstructions: [3.14159 printString]"! ----- Method: Context class>>tallyMethods: (in category 'examples') ----- tallyMethods: aBlock "This method uses the simulator to count the number of calls on each method invoked in evaluating aBlock. Results are given in order of decreasing counts." | prev tallies | tallies := Bag new. prev := aBlock. thisContext sender runSimulated: aBlock contextAtEachStep: [:current | current == prev ifFalse: "call or return" [prev sender == nil ifFalse: "call only" [tallies add: current printString]. prev := current]]. ^tallies sortedCounts "ContextPart tallyMethods: [3.14159 printString]"! ----- Method: Context class>>theReturnMethod (in category 'special context creation') ----- theReturnMethod | meth | meth := self lookupSelector: #return:. meth primitive = 0 ifFalse: [^ self error: 'expected #return: to not be a primitive']. ^ meth! ----- Method: Context class>>trace: (in category 'examples') ----- trace: aBlock "ContextPart trace: [3 factorial]" "This method uses the simulator to print calls and returned values in the Transcript." Transcript clear. ^ self trace: aBlock on: Transcript! ----- Method: Context class>>trace:on: (in category 'examples') ----- trace: aBlock on: aStream "ContextPart trace: [3 factorial]" "This method uses the simulator to print calls to a file." | prev | prev := aBlock. ^ thisContext sender runSimulated: aBlock contextAtEachStep: [:current | Sensor anyButtonPressed ifTrue: [^ nil]. current == prev ifFalse: [prev sender ifNil: [aStream space; nextPut: $^. self carefullyPrint: current top on: aStream]. aStream cr. (current depthBelow: aBlock) timesRepeat: [aStream space]. self carefullyPrint: current receiver on: aStream. aStream space; nextPutAll: current selector; flush. prev := current]]! ----- Method: Context class>>trace:onFileNamed: (in category 'examples') ----- trace: aBlock onFileNamed: fileName "ContextPart trace: [3 factorial] onFileNamed: 'trace'" "This method uses the simulator to print calls to a file." ^FileStream fileNamed: fileName do: [ :file | self trace: aBlock on: file ]! ----- Method: Context>>aboutToReturn:through: (in category 'private') ----- aboutToReturn: result through: firstUnwindContext "Called from VM when an unwindBlock is found between self and its home. Return to home's sender, executing unwind blocks on the way." self methodReturnContext return: result through: firstUnwindContext! ----- Method: Context>>activateMethod:withArgs:receiver:class: (in category 'controlling') ----- activateMethod: newMethod withArgs: args receiver: rcvr class: class "Answer a ContextPart initialized with the arguments." ^MethodContext sender: self receiver: rcvr method: newMethod arguments: args! ----- Method: Context>>activateReturn:value: (in category 'private') ----- activateReturn: aContext value: value "Activate 'aContext return: value' in place of self, so execution will return to aContext's sender" ^MethodContext sender: self receiver: aContext method: MethodContext theReturnMethod arguments: {value}! ----- Method: Context>>activeHome (in category 'accessing') ----- activeHome "If executing closure, search senders for the activation of the original (outermost) method that (indirectly) created my closure (the closureHome). If the closureHome is not found on the sender chain answer nil." | methodReturnContext | self isExecutingBlock ifFalse: [^self]. self sender ifNil: [^nil]. methodReturnContext := self methodReturnContext. ^self sender findContextSuchThat: [:ctxt | ctxt = methodReturnContext]! ----- Method: Context>>activeOuterContext (in category 'accessing') ----- activeOuterContext "If executing closure, search senders for the activation in which the receiver's closure was created (the receiver's outerContext). If the outerContext is not found on the sender chain answer nil." | outerContext | self isExecutingBlock ifFalse: [^self]. self sender ifNil: [^nil]. outerContext := self outerContext. ^self sender findContextSuchThat: [:ctxt | ctxt = outerContext]! ----- Method: Context>>asContext (in category 'closure support') ----- asContext ^ self! ----- Method: Context>>asMessage (in category 'converting') ----- asMessage "Answer a Message that would have activated the receiver, derived from my sender." ^Message selector: sender method selector arguments: ((1 to: sender method numArgs) collect: [:i| sender tempAt: i])! ----- Method: Context>>at: (in category 'accessing') ----- 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. Override the default primitive to give latitude to the VM in context management." <primitive: 210> index isInteger ifTrue: [self errorSubscriptBounds: index]. index isNumber ifTrue: [^self at: index asInteger] ifFalse: [self errorNonIntegerIndex]! ----- Method: Context>>at:put: (in category 'accessing') ----- at: index put: value "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. Override the default primitive to give latitude to the VM in context management." <primitive: 211> index isInteger ifTrue: [self errorSubscriptBounds: index]. index isNumber ifTrue: [^self at: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]! ----- Method: Context>>atEnd (in category 'testing') ----- atEnd ^pc >= self endPC! ----- Method: Context>>basicAt: (in category 'accessing') ----- 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. See Object documentation whatIsAPrimitive. Override the default primitive to give latitude to the VM in context management." <primitive: 210> index isInteger ifTrue: [self errorSubscriptBounds: index]. index isNumber ifTrue: [^self at: index asInteger] ifFalse: [self errorNonIntegerIndex]! ----- Method: Context>>basicAt:put: (in category 'accessing') ----- basicAt: index put: value "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. Override the default primitive to give latitude to the VM in context management." <primitive: 211> index isInteger ifTrue: [self errorSubscriptBounds: index]. index isNumber ifTrue: [^self at: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]! ----- Method: Context>>basicSize (in category 'accessing') ----- basicSize "Primitive. Answer the number of indexable variables in the receiver. This value is the same as the largest legal subscript. Essential. Do not override in any subclass. See Object documentation whatIsAPrimitive. Override the default primitive to give latitude to the VM in context management." <primitive: 212> "The number of indexable fields of fixed-length objects is 0" ^self primitiveFail! ----- Method: Context>>blockReturnTop (in category 'instruction decoding (closures)') ----- blockReturnTop "Simulate the interpreter's action when a ReturnTopOfStackToCaller bytecode is encountered in the receiver. This should only happen in a closure activation." self assert: closureOrNil isClosure. ^self return: self pop from: self! ----- Method: Context>>bottomContext (in category 'query') ----- bottomContext "Return the last context (the first context invoked) in my sender chain" ^ self findContextSuchThat: [:c | c sender isNil]! ----- Method: Context>>cachesStack (in category 'private-debugger') ----- cachesStack ^ false "^self selector == #valueUninterruptably and: [self receiver class == BlockContext]"! ----- Method: Context>>canHandleSignal: (in category 'private-exceptions') ----- 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]. ! ----- Method: Context>>cannotReturn: (in category 'private-exceptions') ----- cannotReturn: result closureOrNil ifNotNil: [^self cannotReturn: result to: self home sender]. ToolSet debugContext: thisContext label: 'computation has been terminated' contents: nil! ----- Method: Context>>cannotReturn:to: (in category 'private') ----- cannotReturn: result to: homeContext "The receiver tried to return result to homeContext that no longer exists." ^ BlockCannotReturn new result: result; deadHome: homeContext; signal! ----- Method: Context>>capturedTempNames (in category 'closure support') ----- capturedTempNames ^ self methodNode scope capturedVars collect: [:var | var name]! ----- Method: Context>>client (in category 'accessing') ----- client "Answer the client, that is, the object that sent the message that created this context." ^sender receiver! ----- Method: Context>>closure (in category 'accessing') ----- closure ^closureOrNil! ----- Method: Context>>closureCopy:copiedValues: (in category 'controlling') ----- closureCopy: numArgs copiedValues: anArray "Distinguish a block of code from its enclosing method by creating a BlockClosure for that block. The compiler inserts into all methods that contain blocks the bytecodes to send the message closureCopy:copiedValues:. Do not use closureCopy:copiedValues: in code that you write!! Only the compiler can decide to send the message closureCopy:copiedValues:. Fail if numArgs is not a SmallInteger. Optional. No Lookup. See Object documentation whatIsAPrimitive." <primitive: 200> ^BlockClosure outerContext: self startpc: pc + 2 numArgs: numArgs copiedValues: anArray! ----- Method: Context>>completeCallee: (in category 'system simulation') ----- completeCallee: aContext "Simulate the execution of bytecodes until a return to the receiver." | ctxt current ctxt1 | ctxt := aContext. [ctxt == current or: [ctxt hasSender: self]] whileTrue: [current := ctxt. ctxt1 := ctxt quickStep. ctxt1 ifNil: [self halt]. ctxt := ctxt1]. ^self stepToSendOrReturn! ----- Method: Context>>contextStack (in category 'debugger access') ----- contextStack "Answer an Array of the contexts on the receiver's sender chain." ^self stackOfSize: 100000! ----- Method: Context>>contextTag (in category 'closure support') ----- contextTag "Context tags may be used for referring to contexts instead of contexts themselves as they can be copied and will continue to work in other processes (continuations). By default, we use the context itself to as its tag." ^self! ----- Method: Context>>copyStack (in category 'query') ----- copyStack ^ self copyTo: nil! ----- Method: Context>>copyTo: (in category 'query') ----- copyTo: aContext "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender." | copy | self == aContext ifTrue: [ ^nil ]. copy := self copy. sender ifNotNil: [ copy privSender: (sender copyTo: aContext) ]. ^copy! ----- Method: Context>>copyTo:bottomContextDo: (in category 'query') ----- copyTo: aContext bottomContextDo: aBlock "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. Evaluate aBlock with the copy of bottom context when it still points to the original sender." | copy | self == aContext ifTrue: [ ^nil ]. copy := self copy. sender ifNil: [ aBlock value: copy ] ifNotNil: [ sender == aContext ifTrue: [ aBlock value: copy ]. copy privSender: (sender copyTo: aContext bottomContextDo: aBlock) ]. ^copy! ----- Method: Context>>cut: (in category 'private') ----- cut: aContext "Cut aContext and its senders from my sender chain" | ctxt callee | ctxt := self. [ctxt == aContext] whileFalse: [ callee := ctxt. ctxt := ctxt sender. ctxt ifNil: [aContext ifNotNil: [self error: 'aContext not a sender']]. ]. callee privSender: nil. ! ----- Method: Context>>defaultIntegerBase (in category 'debugger access') ----- defaultIntegerBase "Answer the default base in which to print integers. Defer to the class the code is compiled in." ^[method methodClass defaultIntegerBaseInDebugger] on: MessageNotUnderstood do: [:ex| 10]! ----- Method: Context>>depthBelow: (in category 'debugger access') ----- depthBelow: aContext "Answer how many calls there are between this and aContext." | this depth | this := self. depth := 0. [this == aContext or: [this == nil]] whileFalse: [this := this sender. depth := depth + 1]. ^depth! ----- Method: Context>>doDup (in category 'instruction decoding') ----- doDup "Simulate the action of a 'duplicate top of stack' bytecode." self push: self top! ----- Method: Context>>doItScope (in category 'closure support') ----- doItScope "scope (environment) for expressions executed within a method context. self will be the receiver of the do-it method. We want temp vars directly accessible" ^ self methodNode scope asDoItScope! ----- Method: Context>>doPop (in category 'instruction decoding') ----- doPop "Simulate the action of a 'remove top of stack' bytecode." self pop! ----- Method: Context>>doPrimitive:method:receiver:args: (in category 'private') ----- doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments "Simulate a primitive method whose index is primitiveIndex. The simulated receiver and arguments are given as arguments to this message. If successful, push result and return resuming context, else ^ {errCode, PrimitiveFailToken}. Any primitive which provokes execution needs to be intercepted and simulated to avoid execution running away." | value | "Judicious use of primitive 19 (a null primitive that doesn't do anything) prevents the debugger from entering various run-away activities such as spawning a new process, etc. Injudicious use results in the debugger not being able to debug interesting code, such as the debugger itself. hence use primitive 19 with care :-)" "SystemNavigation new browseAllSelect: [:m| m primitive = 19]" primitiveIndex = 19 ifTrue: [ToolSet debugContext: self label:'Code simulation error' contents: nil]. ((primitiveIndex between: 201 and: 222) and: [(self objectClass: receiver) includesBehavior: BlockClosure]) ifTrue: [((primitiveIndex between: 201 and: 205) "BlockClosure>>value[:value:...]" or: [primitiveIndex between: 221 and: 222]) ifTrue: "BlockClosure>>valueNoContextSwitch[:]" [^receiver simulateValueWithArguments: arguments caller: self]. primitiveIndex = 206 ifTrue: "BlockClosure>>valueWithArguments:" [^receiver simulateValueWithArguments: arguments first caller: self]]. primitiveIndex = 83 ifTrue: "afr 9/11/1998 19:50" "Object>>perform:[with:...]" [^self send: arguments first to: receiver with: arguments allButFirst super: false]. primitiveIndex = 84 ifTrue: "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:" [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (self objectClass: receiver)]. primitiveIndex = 100 ifTrue: "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:" [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (arguments at: 3)]. "Mutex>>primitiveEnterCriticalSection Mutex>>primitiveTestAndSetOwnershipOfCriticalSection" (primitiveIndex = 186 or: [primitiveIndex = 187]) ifTrue: [| active effective | active := Processor activeProcess. effective := active effectiveProcess. "active == effective" value := primitiveIndex = 186 ifTrue: [receiver primitiveEnterCriticalSectionOnBehalfOf: effective] ifFalse: [receiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: effective]. ^(self isPrimFailToken: value) ifTrue: [value] ifFalse: [self push: value]]. primitiveIndex = 188 ifTrue: "eem 5/27/2008 11:10 Object>>withArgs:executeMethod:" [^MethodContext sender: self receiver: receiver method: (arguments at: 2) arguments: (arguments at: 1)]. "Closure primitives" (primitiveIndex = 200 and: [self == receiver]) ifTrue: "ContextPart>>closureCopy:copiedValues:; simulated to get startpc right" [^self push: (BlockClosure outerContext: receiver startpc: pc + 2 numArgs: arguments first copiedValues: arguments last)]. primitiveIndex = 118 ifTrue: "tryPrimitive:withArgs:; avoid recursing in the VM" [(arguments size = 2 and: [arguments first isInteger and: [(self objectClass: arguments last) == Array]]) ifFalse: [^ContextPart primitiveFailTokenFor: nil]. ^self doPrimitive: arguments first method: meth receiver: receiver args: arguments last]. value := primitiveIndex = 120 "FFI method" ifTrue: [(meth literalAt: 1) tryInvokeWithArguments: arguments] ifFalse: [primitiveIndex = 117 "named primitives" ifTrue: [self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments] ifFalse: [receiver tryPrimitive: primitiveIndex withArgs: arguments]]. ^(self isPrimFailToken: value) ifTrue: [value] ifFalse: [self push: value]! ----- Method: Context>>doesNotUnderstand: (in category 'error handling') ----- doesNotUnderstand: aMessage "Attempt to catch those mysterious callPrimitive: sends..." aMessage selector == #callPrimitive: ifTrue: [ContextPart classPool at: #Once put: true. ContextPart compile: 'callPrimitive: index Once ifTrue: [Once := false. self error: ''should not happen...'']'. self error: 'callPrimitive: invoked!!!!']. ^super doesNotUnderstand: aMessage! ----- Method: Context>>endPC (in category 'private') ----- endPC ^closureOrNil ifNil: [method endPC] ifNotNil: [closureOrNil endPC]! ----- Method: Context>>exceptionMessage (in category 'accessing') ----- exceptionMessage ^ self selector caseOf: { [#doesNotUnderstand:] -> [self tempAt: 1]. [#notYetImplemented] -> [self asMessage]. [#shouldBeImplemented] -> [self asMessage]. [#subclassResponsibility] -> [self asMessage]} otherwise: [self error: 'This context is not the result of a message exception.'].! ----- Method: Context>>failPrimitiveWith: (in category 'system simulation') ----- failPrimitiveWith: maybePrimFailToken "The receiver is a freshly-created context on a primitive method. Skip the callPrimitive: bytecode and store the primitive fail code if there is one and the method consumes it." self skipCallPrimitive. ((self isPrimFailToken: maybePrimFailToken) and: [method encoderClass isStoreAt: pc in: method]) ifTrue: [self at: stackp put: maybePrimFailToken last]! ----- Method: Context>>findContextSuchThat: (in category 'query') ----- findContextSuchThat: testBlock "Search self and my sender chain for first one that satisfies testBlock. Return nil if none satisfy" | ctxt | ctxt := self. [ctxt isNil] whileFalse: [ (testBlock value: ctxt) ifTrue: [^ ctxt]. ctxt := ctxt sender. ]. ^ nil! ----- Method: Context>>findNextHandlerContextStarting (in category 'private-exceptions') ----- findNextHandlerContextStarting "Return the next handler marked context, returning nil if there is none. Search starts with self and proceeds up to nil." | ctx | <primitive: 197> ctx := self. [ctx isHandlerContext ifTrue:[^ctx]. (ctx := ctx sender) == nil ] whileFalse. ^nil! ----- Method: Context>>findNextUnwindContextUpTo: (in category 'private-exceptions') ----- findNextUnwindContextUpTo: aContext "Return the next unwind marked above the receiver, returning nil if there is none. Search proceeds up to but not including aContext." | ctx | <primitive: 195> ctx := self. [(ctx := ctx sender) == nil or: [ctx == aContext]] whileFalse: [ ctx isUnwindContext ifTrue: [^ctx]]. ^nil! ----- Method: Context>>findSecondToOldestSimilarSender (in category 'query') ----- findSecondToOldestSimilarSender "Search the stack for the second-to-oldest occurance of self's method. Very useful for an infinite recursion. Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning." | sec ctxt bot | sec := self. ctxt := self. [ bot := ctxt findSimilarSender. bot isNil ] whileFalse: [ sec := ctxt. ctxt := bot. ]. ^ sec ! ----- Method: Context>>findSimilarSender (in category 'query') ----- findSimilarSender "Return the closest sender with the same method, return nil if none found" ^sender findContextSuchThat: [:c| c method == method]! ----- Method: Context>>freeNames (in category 'closure support') ----- freeNames ^ self methodNode freeNames! ----- Method: Context>>freeNamesAndValues (in category 'closure support') ----- freeNamesAndValues | aStream eval | eval := [:string | self class evaluatorClass new evaluate2: (ReadStream on: string) in: self to: nil notifying: nil "fix this" ifFail: [self error: 'bug'] logged: false]. aStream := '' writeStream. self freeNames doWithIndex: [:name :index | aStream nextPutAll: name; nextPut: $:; space; tab. (eval value: name) printOn: aStream. aStream cr]. ^ aStream contents! ----- Method: Context>>handleSignal: (in category 'private-exceptions') ----- 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) cull: exception ] ensure: [self tempAt: 3 put: true]. self return: val. "return from self if not otherwise directed in handle block" ! ----- Method: Context>>hasContext: (in category 'query') ----- hasContext: aContext "Answer whether aContext is me or one of my senders" ^ (self findContextSuchThat: [:c | c == aContext]) notNil! ----- Method: Context>>hasInstVarRef (in category 'accessing') ----- hasInstVarRef "Answer whether the receiver references an instance variable." ^method hasInstVarRef.! ----- Method: Context>>hasMethodReturn (in category 'accessing') ----- hasMethodReturn ^closureOrNil hasMethodReturn! ----- Method: Context>>hasSender: (in category 'controlling') ----- hasSender: context "Answer whether the receiver is strictly above context on the stack." | s | self == context ifTrue: [^false]. s := sender. [s == nil] whileFalse: [s == context ifTrue: [^true]. s := s sender]. ^false! ----- Method: Context>>home (in category 'accessing') ----- home "Answer the context in which the receiver was defined." closureOrNil == nil ifTrue: [^self]. ^closureOrNil outerContext home! ----- Method: Context>>insertSender: (in category 'private') ----- insertSender: aContext "Insert aContext and its sender chain between me and my sender. Return new callee of my original sender." | ctxt | ctxt := aContext bottomContext. ctxt privSender: sender. sender := aContext. ^ctxt! ----- Method: Context>>instVarAt:put: (in category 'private') ----- instVarAt: index put: value index = 3 ifTrue: [self stackp: value. ^ value]. ^ super instVarAt: index put: value! ----- Method: Context>>isBottomContext (in category 'query') ----- isBottomContext "Answer if this is the last context (the first context invoked) in my sender chain" ^sender isNil! ----- Method: Context>>isClosureContext (in category 'closure support') ----- isClosureContext ^ self isExecutingBlock! ----- Method: Context>>isContext (in category 'query') ----- isContext ^true! ----- Method: Context>>isDead (in category 'query') ----- isDead "Has self finished" ^ pc isNil! ----- Method: Context>>isExecutingBlock (in category 'accessing') ----- isExecutingBlock "Is this executing a block versus a method? In the new closure implemetation this is true if closureOrNil is not nil, in which case it should be holding a BlockClosure." ^closureOrNil notNil! ----- Method: Context>>isHandlerContext (in category 'private-exceptions') ----- isHandlerContext "is this context for method that is marked?" ^method primitive = 199! ----- Method: Context>>isMethodContext (in category 'testing') ----- isMethodContext ^ true! ----- Method: Context>>isPrimFailToken: (in category 'private') ----- isPrimFailToken: anObject ^(self objectClass: anObject) == Array and: [anObject size = 2 and: [anObject first == PrimitiveFailToken]]! ----- Method: Context>>isUnwindContext (in category 'private-exceptions') ----- isUnwindContext "is this context for method that is marked?" ^method primitive = 198! ----- Method: Context>>jump (in category 'controlling') ----- jump "Abandon thisContext and resume self instead (using the same current process). You may want to save thisContext's sender before calling this so you can jump back to it. Self MUST BE a top context (ie. a suspended context or a abandoned context that was jumped out of). A top context already has its return value on its stack (see Interpreter>>primitiveSuspend and other suspending primitives). thisContext's sender is converted to a top context (by pushing a nil return value on its stack) so it can be jump back to." | top | "Make abandoned context a top context (has return value (nil)) so it can be jumped back to" thisContext sender push: nil. "Pop self return value then return it to self (since we jump to self by returning to it)" stackp = 0 ifTrue: [self stepToSendOrReturn]. stackp = 0 ifTrue: [self push: nil]. "must be quick return self/constant" top := self pop. thisContext privSender: self. ^ top! ----- Method: Context>>jump: (in category 'instruction decoding') ----- jump: distance "Simulate the action of a 'unconditional jump' bytecode whose offset is the argument, distance." pc := pc + distance! ----- Method: Context>>jump:if: (in category 'instruction decoding') ----- jump: distance if: condition "Simulate the action of a 'conditional jump' bytecode whose offset is the argument, distance, and whose condition is the argument, condition." | bool | bool := self pop. (bool == true or: [bool == false]) ifFalse: [ ^self send: #mustBeBooleanIn: to: bool with: {self} super: false]. (bool eqv: condition) ifTrue: [self jump: distance]! ----- Method: Context>>longStack (in category 'debugger access') ----- longStack "Answer a String showing the top 100 contexts on my sender chain." ^ String streamContents: [:strm | (self stackOfSize: 100) do: [:item | strm print: item; cr]]! ----- Method: Context>>method (in category 'accessing') ----- method ^method! ----- Method: Context>>methodClass (in category 'debugger access') ----- methodClass "Answer the class in which the receiver's method was found." ^method methodClass ifNil: [self objectClass: receiver]! ----- Method: Context>>methodNode (in category 'accessing') ----- methodNode ^method methodNode! ----- Method: Context>>methodNodeFormattedAndDecorated: (in category 'accessing') ----- methodNodeFormattedAndDecorated: decorate "Answer a method node made from pretty-printed (and colorized, if decorate is true) source text." ^method methodNodeFormattedAndDecorated: decorate! ----- Method: Context>>methodReturnConstant: (in category 'instruction decoding') ----- methodReturnConstant: value "Simulate the action of a 'return constant' bytecode whose value is the argument, value. This corresponds to a source expression like '^0'." ^self return: value from: self methodReturnContext! ----- Method: Context>>methodReturnContext (in category 'accessing') ----- methodReturnContext "Answer the context from which an ^-return should return from." closureOrNil == nil ifTrue: [^self]. ^closureOrNil outerContext methodReturnContext! ----- Method: Context>>methodReturnReceiver (in category 'instruction decoding') ----- methodReturnReceiver "Simulate the action of a 'return receiver' bytecode. This corresponds to the source expression '^self'." ^self return: receiver from: self methodReturnContext! ----- Method: Context>>methodReturnTop (in category 'instruction decoding') ----- methodReturnTop "Simulate the action of a 'return top of stack' bytecode. This corresponds to source expressions like '^something'." ^self return: self pop from: self methodReturnContext! ----- Method: Context>>namedTempAt: (in category 'debugger access') ----- namedTempAt: index "Answer the value of the temp at index in the receiver's sequence of tempNames." ^self debuggerMap namedTempAt: index in: self! ----- Method: Context>>namedTempAt:put: (in category 'debugger access') ----- namedTempAt: index put: aValue "Set the value of the temp at index in the receiver's sequence of tempNames. (Note that if the value is a copied value it is also set out along the lexical chain, but alas not in along the lexical chain.)." ^self debuggerMap namedTempAt: index put: aValue in: self! ----- Method: Context>>nextHandlerContext (in category 'private-exceptions') ----- nextHandlerContext ^sender ifNotNil: [sender findNextHandlerContextStarting]! ----- Method: Context>>numArgs (in category 'accessing') ----- numArgs "Answer the number of arguments for this activation." ^closureOrNil ifNil: [method numArgs] ifNotNil: [closureOrNil numArgs]! ----- Method: Context>>numTemps (in category 'accessing') ----- numTemps "Answer the number of temporaries for this activation; this includes the number of arguments, and for blocks, the number of copied values." ^closureOrNil ifNil: [method numTemps] ifNotNil: [closureOrNil numTemps]! ----- Method: Context>>object:basicAt: (in category 'mirror primitives') ----- object: anObject basicAt: index "Answer the value of an indexable element in the argument anObject without sending it a message. Fail if the argument index is not an Integer or is out of bounds, or if anObject is not indexable. This mimics the action of the VM when it indexes an object. Used to simulate the execution machinery by, for example, the debugger. Primitive. See Object documentation whatIsAPrimitive." <primitive: 60> index isInteger ifTrue: [self errorSubscriptBounds: index]. index isNumber ifTrue: [^self object: anObject basicAt: index asInteger] ifFalse: [self errorNonIntegerIndex]! ----- Method: Context>>object:basicAt:put: (in category 'mirror primitives') ----- object: anObject basicAt: index put: value "Store the last argument value in the indexable element of the argument anObject indicated by index without sending anObject a message. Fail if the argument index is not an Integer or is out of bounds, or if anObject is not indexable, or if value is an inappropriate value for anObject's indexable slots. This mimics the action of the VM when it indexes an object. Used to simulate the execution machinery by, for example, the debugger. Primitive. See Object documentation whatIsAPrimitive." <primitive: 61> index isInteger ifTrue: [(index >= 1 and: [index <= (self objectSize: anObject)]) ifTrue: [self errorImproperStore] ifFalse: [self errorSubscriptBounds: index]]. index isNumber ifTrue: [^self object: anObject basicAt: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]! ----- Method: Context>>object:eqeq: (in category 'mirror primitives') ----- object: anObject eqeq: anOtherObject "Answer whether the first and second arguments are the same object (have the same object pointer) without sending a message to the first argument. This mimics the action of the VM when it compares two object pointers. Used to simulate the execution machinery by, for example, the debugger. Primitive. See Object documentation whatIsAPrimitive." <primitive: 110> self primitiveFailed! ----- Method: Context>>object:instVarAt: (in category 'mirror primitives') ----- object: anObject instVarAt: anIndex "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 for the debugger. See Object documentation whatIsAPrimitive." <primitive: 73> "Access beyond fixed variables." ^self object: anObject basicAt: anIndex - (self objectClass: anObject) instSize! ----- Method: Context>>object:instVarAt:put: (in category 'mirror primitives') ----- object: anObject instVarAt: anIndex put: aValue "Primitive. Store a value into a fixed variable in the argument anObject. 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 for the debugger. See Object documentation whatIsAPrimitive." <primitive: 74> "Access beyond fixed fields" ^self object: anObject basicAt: anIndex - (self objectClass: anObject) instSize put: aValue! ----- Method: Context>>object:perform:withArguments:inClass: (in category 'mirror primitives') ----- object: anObject perform: selector withArguments: argArray inClass: lookupClass "Send the selector, aSymbol, to anObject with arguments in argArray. Fail if the number of arguments expected by the selector does not match the size of argArray, or if lookupClass cannot be found among the anObject's superclasses. Primitive. Essential for the debugger." <primitive: 100 error: error> (selector isSymbol) ifFalse: [^self error: 'selector argument must be a Symbol']. (argArray isMemberOf: Array) ifFalse: [^self error: 'argArray must be an Array']. (selector numArgs = argArray size) ifFalse: [^self error: 'incorrect number of arguments']. ((self objectClass: anObject) == lookupClass or: [(self objectClass: anObject) inheritsFrom: lookupClass]) ifFalse: [^self error: 'lookupClass is not in anObject''s inheritance chain']. self primitiveFailed! ----- Method: Context>>objectClass: (in category 'mirror primitives') ----- objectClass: anObject "Answer the class of the argument anObject without sending it a message. This mimics the action of the VM when it fetches an object's class. Used to simulate the execution machinery by, for example, the debugger. Primitive. See Object documentation whatIsAPrimitive." <primitive: 111> self primitiveFailed! ----- Method: Context>>objectSize: (in category 'mirror primitives') ----- objectSize: anObject "Answer the number of indexable variables in the argument anObject without sending it a message. This mimics the action of the VM when it fetches an object's variable size. Used to simulate the execution machinery by, for example, the debugger. Primitive. See Object documentation whatIsAPrimitive." <primitive: 62> "The number of indexable fields of fixed-length objects is 0" ^0! ----- Method: Context>>outerContext (in category 'accessing') ----- outerContext "Answer the context within which the receiver is nested." ^closureOrNil == nil ifFalse: [closureOrNil outerContext]! ----- Method: Context>>pc (in category 'debugger access') ----- pc "Answer the index of the next bytecode to be executed." ^pc! ----- Method: Context>>pop (in category 'controlling') ----- pop "Answer the top of the receiver's stack and remove the top of the stack." | val | val := self at: stackp. self stackp: stackp - 1. ^ val! ----- Method: Context>>popIntoLiteralVariable: (in category 'instruction decoding') ----- popIntoLiteralVariable: value "Simulate the action of bytecode that removes the top of the stack and stores it into a literal variable of my method." self object: value instVarAt: ValueIndex put: self pop! ----- Method: Context>>popIntoReceiverVariable: (in category 'instruction decoding') ----- popIntoReceiverVariable: offset "Simulate the action of bytecode that removes the top of the stack and stores it into an instance variable of my receiver." self object: receiver instVarAt: offset + 1 put: self pop! ----- Method: Context>>popIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex "Simulate the action of bytecode that removes the top of the stack and stores it into an offset in one of my local variables being used as a remote temp vector." self object: (self at: tempVectorIndex + 1) basicAt: remoteTempIndex + 1 put: self pop! ----- Method: Context>>popIntoTemporaryVariable: (in category 'instruction decoding') ----- popIntoTemporaryVariable: offset "Simulate the action of bytecode that removes the top of the stack and stores it into one of my temporary variables." self at: offset + 1 put: self pop! ----- Method: Context>>print:on: (in category 'debugger access') ----- print: anObject on: aStream "Safely print anObject in the face of direct ProtoObject subclasses" | objClass title | objClass := self objectClass: anObject. ((objClass canUnderstand: #isInteger) and: [anObject isInteger]) ifTrue: [^anObject storeOn: aStream base: self defaultIntegerBase]. (objClass canUnderstand: #printOn:) ifTrue: [^anObject printOn: aStream]. title := objClass name. aStream nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']); nextPutAll: title! ----- Method: Context>>printDetails: (in category 'printing') ----- printDetails: strm "Put my class>>selector and instance variables and arguments and temporaries on the stream. Protect against errors during printing." | pe str pos | self printOn: strm. strm cr. strm tab; nextPutAll: 'Receiver: '. pe := '<<error during printing>>'. strm nextPutAll: ([receiver printStringLimitedTo: 90] ifError: [:err :rcvr | pe]). strm cr; tab; nextPutAll: 'Arguments and temporary variables: '; cr. str := [(self tempsAndValuesLimitedTo: 80 indent: 2) padded: #right to: 1 with: $x] ifError: [:err :rcvr | pe]. strm nextPutAll: (str allButLast). strm cr; tab; nextPutAll: 'Receiver''s instance variables: '; cr. pos := strm position. [receiver longPrintOn: strm limitedTo: 80 indent: 2] ifError: [:err :rcvr | strm nextPutAll: pe]. pos = strm position ifTrue: ["normal printString for an Array (it has no inst vars)" strm nextPutAll: ([receiver printStringLimitedTo: 90] ifError: [:err :rcvr | pe])]. strm peekLast == Character cr ifFalse: [strm cr].! ----- Method: Context>>printOn: (in category 'printing') ----- printOn: aStream | selector class mclass | method ifNil: [^super printOn: aStream]. self outerContext ifNotNil: [:outerContext| aStream nextPutAll: '[] in '. outerContext printOn: aStream. ^self]. class := self objectClass: receiver. mclass := method methodClass. aStream nextPutAll: class name. mclass ~~ class ifTrue: [aStream nextPut: $(; nextPutAll: mclass name; nextPut: $)]. selector := method selector ifNil: [method defaultSelector]. aStream nextPutAll: '>>'; nextPutAll: selector. (selector == #doesNotUnderstand: and: [(self objectClass: (self tempAt: 1)) == Message]) ifTrue: [aStream space. (self tempAt: 1) selector printOn: aStream]! ----- Method: Context>>printString (in category 'printing') ----- printString "Answer an emphasized string in case of a breakpoint method" ^(method notNil and: [method hasBreakpoint]) ifTrue:[(super printString , ' [break]') asText allBold] ifFalse:[super printString]! ----- Method: Context>>privRefresh (in category 'initialize-release') ----- privRefresh "Reinitialize the receiver so that it is in the state it was at its creation." closureOrNil ifNotNil: [pc := closureOrNil startpc. self stackp: closureOrNil numArgs + closureOrNil numCopiedValues. 1 to: closureOrNil numCopiedValues do: [:i | self tempAt: closureOrNil numArgs + i put: (closureOrNil at: i)]] ifNil: [pc := method initialPC. self stackp: method numTemps. method numArgs+1 to: method numTemps do: [:i | self tempAt: i put: nil]]! ----- Method: Context>>privRefreshWith: (in category 'initialize-release') ----- privRefreshWith: aCompiledMethod "Reinitialize the receiver as though it had been for a different method. Used by a Debugger when one of the methods to which it refers is recompiled." aCompiledMethod isCompiledMethod ifFalse: [self error: 'method can only be set to aCompiledMethod']. method := aCompiledMethod. self assert: closureOrNil == nil. "was: receiverMap := nil." self privRefresh! ----- Method: Context>>privSender: (in category 'private') ----- privSender: aContext sender := aContext! ----- Method: Context>>push: (in category 'controlling') ----- push: val "Push val on the receiver's stack." self stackp: stackp + 1. self at: stackp put: val! ----- Method: Context>>push:fromIndexable: (in category 'private') ----- push: numObjects fromIndexable: anIndexableCollection "Push the elements of anIndexableCollection onto the receiver's stack. Do not call directly. Called indirectly by {1. 2. 3} constructs." 1 to: numObjects do: [:i | self push: (anIndexableCollection at: i)]! ----- Method: Context>>pushActiveContext (in category 'instruction decoding') ----- pushActiveContext "Simulate the action of bytecode that pushes the the active context on the top of its own stack." self push: self! ----- Method: Context>>pushArgs:from: (in category 'system simulation') ----- pushArgs: args "<Array>" from: sendr "<ContextPart>" "Helps simulate action of the value primitive for closures. This is used by ContextPart>>runSimulated:contextAtEachStep:" closureOrNil ifNil: [self error: 'context needs a closure!!'] ifNotNil: ["See BlockClosure>>asContextWithSender:" stackp ~= (closureOrNil numArgs + closureOrNil numCopiedValues) ifTrue: [self error: 'stack pointer is incorrect!!'].]. 1 to: closureOrNil numArgs do: [:i| self at: i put: (args at: i)]. sender := sendr! ----- Method: Context>>pushClosureCopyNumCopiedValues:numArgs:blockSize: (in category 'instruction decoding') ----- pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize "Simulate the action of a 'closure copy' bytecode whose result is the new BlockClosure for the following code" | copiedValues | numCopied > 0 ifTrue: [copiedValues := Array new: numCopied. numCopied to: 1 by: -1 do: [:i| copiedValues at: i put: self pop]] ifFalse: [copiedValues := nil]. self push: (BlockClosure outerContext: self startpc: pc numArgs: numArgs copiedValues: copiedValues). self jump: blockSize! ----- Method: Context>>pushConsArrayWithElements: (in category 'instruction decoding (closures)') ----- pushConsArrayWithElements: numElements | array | array := Array new: numElements. numElements to: 1 by: -1 do: [:i| array at: i put: self pop]. self push: array! ----- Method: Context>>pushConstant: (in category 'instruction decoding') ----- pushConstant: value "Simulate the action of bytecode that pushes the constant, value, on the top of the stack." self push: value! ----- Method: Context>>pushLiteralVariable: (in category 'instruction decoding') ----- pushLiteralVariable: value "Simulate the action of bytecode that pushes the contents of the literal variable whose index is the argument, index, on the top of the stack." self push: (self object: value instVarAt: ValueIndex)! ----- Method: Context>>pushNewArrayOfSize: (in category 'instruction decoding') ----- pushNewArrayOfSize: arraySize self push: (Array new: arraySize)! ----- Method: Context>>pushReceiver (in category 'instruction decoding') ----- pushReceiver "Simulate the action of bytecode that pushes the active context's receiver on the top of the stack." self push: receiver! ----- Method: Context>>pushReceiverVariable: (in category 'instruction decoding') ----- pushReceiverVariable: offset "Simulate the action of bytecode that pushes the contents of the receiver's instance variable whose index is the argument, index, on the top of the stack." self push: (self object: receiver instVarAt: offset + 1)! ----- Method: Context>>pushRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex "Simulate the action of bytecode that pushes the value at remoteTempIndex in one of my local variables being used as a remote temp vector." self push: (self object: (self at: tempVectorIndex + 1) basicAt: remoteTempIndex + 1)! ----- Method: Context>>pushTemporaryVariable: (in category 'instruction decoding') ----- pushTemporaryVariable: offset "Simulate the action of bytecode that pushes the contents of the temporary variable whose index is the argument, index, on the top of the stack." self push: (self at: offset + 1)! ----- Method: Context>>quickSend:to:with:super: (in category 'controlling') ----- quickSend: selector to: rcvr with: arguments super: superFlag "Send the given selector with arguments in an environment which closely resembles the non-simulating environment, with an interjected unwind-protected block to catch nonlocal returns. Attention: don't get lost!! This beautiful method is due to Hans-Martin Mosner. Eliot Miranda merely added the mirror primitive code." | oldSender contextToReturnTo result lookupClass | contextToReturnTo := self. lookupClass := superFlag ifTrue: [method methodClass superclass] ifFalse: [self objectClass: rcvr]. [oldSender := thisContext sender swapSender: self. result := self object: rcvr perform: selector withArguments: arguments inClass: lookupClass. thisContext sender swapSender: oldSender] ifCurtailed: [contextToReturnTo := thisContext sender receiver. "The block context returning nonlocally" contextToReturnTo pc: contextToReturnTo previousPc. "skip to front of return bytecode causing this unwind" contextToReturnTo willReturnTopFromMethod ifTrue: "If it was a returnTop, push the value to be returned. Otherwise the value is implicit in the bytecode" [contextToReturnTo push: (thisContext sender tempAt: 1)]. thisContext swapSender: thisContext home sender. "Make this block return to the method's sender" contextToReturnTo]. contextToReturnTo push: result. ^contextToReturnTo! ----- Method: Context>>quickStep (in category 'system simulation') ----- quickStep "If the next instruction is a send, just perform it. Otherwise, do a normal step." self willReallySend ifTrue: [QuickStep := self]. ^self step! ----- Method: Context>>rearmHandlerDuring: (in category 'private-exceptions') ----- rearmHandlerDuring: aBlock "Sent to handler (on:do:) contexts only. Makes me re-entrant for the duration of aBlock. Only works in a closure-enabled image" ^ [self tempAt: 3 put: true. aBlock value] ensure: [self tempAt: 3 put: false]! ----- Method: Context>>receiver (in category 'accessing') ----- receiver "Refer to the comment in ContextPart|receiver." ^receiver! ----- Method: Context>>receiver: (in category 'private-exceptions') ----- receiver: r receiver := r! ----- Method: Context>>release (in category 'debugger access') ----- release "Remove information from the receiver and all of the contexts on its sender chain in order to break circularities." self releaseTo: nil! ----- Method: Context>>releaseTo: (in category 'debugger access') ----- releaseTo: caller "Remove information from the receiver and the contexts on its sender chain up to caller in order to break circularities." | c s | c := self. [c == nil or: [c == caller]] whileFalse: [s := c sender. c singleRelease. c := s]! ----- Method: Context>>removeSelf (in category 'accessing') ----- removeSelf "Nil the receiver pointer and answer its former value." | tempSelf | tempSelf := receiver. receiver := nil. ^tempSelf! ----- Method: Context>>restart (in category 'controlling') ----- restart "Unwind thisContext to self and resume from beginning. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" | ctxt unwindBlock | self isDead ifTrue: [self cannotReturn: nil to: self]. self privRefresh. ctxt := thisContext. [ ctxt := ctxt findNextUnwindContextUpTo: self. ctxt isNil ] whileFalse: [ (ctxt tempAt: 2) ifNil:[ ctxt tempAt: 2 put: true. unwindBlock := ctxt tempAt: 1. thisContext terminateTo: ctxt. unwindBlock value]. ]. thisContext terminateTo: self. self jump. ! ----- Method: Context>>restartWithNewReceiver: (in category 'private-exceptions') ----- restartWithNewReceiver: obj self swapReceiver: obj; restart! ----- Method: Context>>resume (in category 'controlling') ----- resume "Roll back thisContext to self and resume. Execute unwind blocks when rolling back. ASSUMES self is a sender of thisContext" self resume: nil! ----- Method: Context>>resume: (in category 'controlling') ----- resume: value "Unwind thisContext to self and resume with value as result of last send. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" | ctxt unwindBlock | self isDead ifTrue: [self cannotReturn: value to: self]. ctxt := thisContext. [ ctxt := ctxt findNextUnwindContextUpTo: self. ctxt isNil ] whileFalse: [ (ctxt tempAt: 2) ifNil:[ ctxt tempAt: 2 put: true. unwindBlock := ctxt tempAt: 1. thisContext terminateTo: ctxt. unwindBlock value]. ]. thisContext terminateTo: self. ^ value ! ----- Method: Context>>resume:through: (in category 'controlling') ----- resume: value through: firstUnwindCtxt "Unwind thisContext to self and resume with value as result of last send. Execute any unwind blocks while unwinding. ASSUMES self is a sender of thisContext." | ctxt unwindBlock | self isDead ifTrue: [self cannotReturn: value to: self]. ctxt := firstUnwindCtxt. [ctxt isNil] whileFalse: [(ctxt tempAt: 2) ifNil: [ctxt tempAt: 2 put: true. unwindBlock := ctxt tempAt: 1. thisContext terminateTo: ctxt. unwindBlock value]. ctxt := ctxt findNextUnwindContextUpTo: self]. thisContext terminateTo: self. ^value ! ----- Method: Context>>return (in category 'controlling') ----- return "Unwind until my sender is on top" self return: receiver! ----- Method: Context>>return: (in category 'controlling') ----- return: value "Unwind thisContext to self and return value to self's sender. Execute any unwind blocks while unwinding. ASSUMES self is a sender of thisContext" sender ifNil: [self cannotReturn: value to: sender]. sender resume: value! ----- Method: Context>>return:from: (in category 'instruction decoding') ----- return: value from: aSender "For simulation. Roll back self to aSender and return value from it. Execute any unwind blocks on the way. ASSUMES aSender is a sender of self" | newTop ctxt | aSender isDead ifTrue: [ ^ self send: #cannotReturn: to: self with: {value} super: false]. newTop := aSender sender. ctxt := self findNextUnwindContextUpTo: newTop. ctxt ifNotNil: [ ^ self send: #aboutToReturn:through: to: self with: {value. ctxt} super: false]. self releaseTo: newTop. newTop ifNotNil: [newTop push: value]. ^ newTop ! ----- Method: Context>>return:through: (in category 'controlling') ----- return: value through: firstUnwindContext "Unwind thisContext to self and return value to self's sender. Execute any unwind blocks while unwinding. ASSUMES self is a sender of thisContext." sender ifNil: [self cannotReturn: value to: sender]. sender resume: value through: firstUnwindContext! ----- Method: Context>>return:to: (in category 'controlling') ----- return: value to: sendr "Simulate the return of value to sendr." self releaseTo: sendr. sendr ifNil: [^ nil]. ^ sendr push: value! ----- Method: Context>>runSimulated:contextAtEachStep: (in category 'system simulation') ----- runSimulated: aBlock contextAtEachStep: block2 "Simulate the execution of the argument, aBlock, until it ends. aBlock MUST NOT contain an '^'. Evaluate block2 with the current context prior to each instruction executed. Answer the simulated value of aBlock." | current | aBlock hasMethodReturn ifTrue: [self error: 'simulation of blocks with ^ can run loose']. current := aBlock asContext. current pushArgs: Array new from: self. [current == self] whileFalse: [block2 value: current. current := current step]. ^self pop! ----- Method: Context>>runUntilErrorOrReturnFrom: (in category 'controlling') ----- runUntilErrorOrReturnFrom: aSender "ASSUMES aSender is a sender of self. Execute self's stack until aSender returns or an unhandled exception is raised. Return a pair containing the new top context and a possibly nil exception. The exception is not nil if it was raised before aSender returned and it was not handled. The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it." "Self is run by jumping directly to it (the active process abandons thisContext and executes self). However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated. We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised. In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext." | error ctxt here topContext | here := thisContext. "Insert ensure and exception handler contexts under aSender" error := nil. ctxt := aSender insertSender: (ContextPart contextOn: UnhandledError do: [:ex | error ifNil: [ error := ex exception. topContext := thisContext. ex resumeUnchecked: here jump] ifNotNil: [ex pass] ]). ctxt := ctxt insertSender: (ContextPart contextEnsure: [error ifNil: [ topContext := thisContext. here jump] ]). self jump. "Control jumps to self" "Control resumes here once above ensure block or exception handler is executed" ^ error ifNil: [ "No error was raised, remove ensure context by stepping until popped" [ctxt isDead] whileFalse: [topContext := topContext stepToCallee]. {topContext. nil} ] ifNotNil: [ "Error was raised, remove inserted above contexts then return signaler context" aSender terminateTo: ctxt sender. "remove above ensure and handler contexts" {topContext. error} ]. ! ----- Method: Context>>secondFromBottom (in category 'query') ----- secondFromBottom "Return the second from bottom of my sender chain" self sender ifNil: [^ nil]. ^ self findContextSuchThat: [:c | c sender sender isNil]! ----- Method: Context>>selector (in category 'debugger access') ----- selector "Answer the selector of the method that created the receiver." ^method selector ifNil: [method defaultSelector]! ----- Method: Context>>selectorCategory (in category 'accessing') ----- selectorCategory "Answer the category to which this message belongs (relative to the receiver). If no superclass categorises this message, use the default." ^method protocol ifNil: [ClassOrganizer default]! ----- Method: Context>>send:super:numArgs: (in category 'instruction decoding') ----- send: selector super: superFlag numArgs: numArgs "Simulate the action of bytecodes that send a message with selector, selector. The argument, superFlag, tells whether the receiver of the message was specified with 'super' in the source method. The arguments of the message are found in the top numArgs locations on the stack and the receiver just below them." | receiver arguments | arguments := Array new: numArgs. numArgs to: 1 by: -1 do: [ :i | arguments at: i put: self pop]. receiver := self pop. QuickStep == self ifTrue: [QuickStep := nil. ^self quickSend: selector to: receiver with: arguments super: superFlag]. ^self send: selector to: receiver with: arguments super: superFlag! ----- Method: Context>>send:to:with:lookupIn: (in category 'controlling') ----- send: selector to: rcvr with: arguments lookupIn: lookupClass "Simulate the action of sending a message with selector and arguments to rcvr. The argument, lookupClass, is the class in which to lookup the message. This is the receiver's class for normal messages, but for super messages it will be some specific class related to the source method." | meth primIndex val ctxt | (meth := lookupClass lookupSelector: selector) ifNil: [^self send: #doesNotUnderstand: to: rcvr with: {Message selector: selector arguments: arguments} lookupIn: lookupClass]. (primIndex := meth primitive) > 0 ifTrue: [val := self doPrimitive: primIndex method: meth receiver: rcvr args: arguments. (self isPrimFailToken: val) ifFalse: [^val]]. (selector == #doesNotUnderstand: and: [lookupClass == ProtoObject]) ifTrue: [^self error: 'Simulated message ', arguments first selector, ' not understood']. ctxt := MethodContext sender: self receiver: rcvr method: meth arguments: arguments. primIndex > 0 ifTrue: [ctxt failPrimitiveWith: val]. ^ctxt! ----- Method: Context>>send:to:with:startClass: (in category 'controlling') ----- send: selector to: rcvr with: args startClass: startClassOrNil "Simulate the action of sending a message with selector, selector, and arguments, args, to receiver. The argument, startClassOrNil, tells whether the selector should be looked up in startClassOrNil or the class of the receiver." | class meth val ctxt | class := startClassOrNil ifNil: [self objectClass: rcvr]. meth := class lookupSelector: selector. meth == nil ifTrue: [^self send: #doesNotUnderstand: to: rcvr with: (Array with: (Message selector: selector arguments: args)) startClass: class]. (args isArray and: [args size = meth numArgs]) ifFalse: [^ContextPart primitiveFailTokenFor: nil]. val := self tryPrimitiveFor: meth receiver: rcvr args: args. ((self objectClass: val) == Array and: [val size = 2 and: [val first == PrimitiveFailToken]]) ifFalse: [^val]. (selector == #doesNotUnderstand: and: [class == ProtoObject]) ifTrue: [^self error: 'Simulated message ' , (args at: 1) selector, ' not understood']. ctxt := self activateMethod: meth withArgs: args receiver: rcvr class: class. ((self objectClass: val) == Array and: [val size = 2 and: [val first == PrimitiveFailToken and: [val last notNil and: [ctxt willStore "long store temp"]]]]) ifTrue: [ctxt at: ctxt stackPtr put: val last]. ^ctxt! ----- Method: Context>>send:to:with:super: (in category 'controlling') ----- send: selector to: rcvr with: arguments super: superFlag "Simulate the action of sending a message with selector arguments to rcvr. The argument, superFlag, tells whether the receiver of the message was specified with 'super' in the source method." ^self send: selector to: rcvr with: arguments lookupIn: (superFlag ifTrue: [method methodClass superclass] ifFalse: [self objectClass: rcvr])! ----- Method: Context>>sender (in category 'debugger access') ----- sender "Answer the context that sent the message that created the receiver." ^sender! ----- Method: Context>>setSender:receiver:method:arguments: (in category 'private') ----- setSender: s receiver: r method: m arguments: args "Create the receiver's initial state." sender := s. receiver := r. method := m. closureOrNil := nil. pc := method initialPC. self stackp: method numTemps. 1 to: args size do: [:i | self at: i put: (args at: i)]! ----- Method: Context>>setSender:receiver:method:closure:startpc: (in category 'private') ----- setSender: s receiver: r method: m closure: c startpc: startpc "Create the receiver's initial state." sender := s. receiver := r. method := m. closureOrNil := c. pc := startpc. stackp := 0! ----- Method: Context>>shortStack (in category 'debugger access') ----- shortStack "Answer a String showing the top ten contexts on my sender chain." ^ String streamContents: [:strm | (self stackOfSize: 10) do: [:item | strm print: item; cr]]! ----- Method: Context>>singleRelease (in category 'debugger access') ----- singleRelease "Remove information from the receiver in order to break circularities." stackp == nil ifFalse: [1 to: stackp do: [:i | self at: i put: nil]]. sender := nil. pc := nil. ! ----- Method: Context>>size (in category 'accessing') ----- size "Primitive. Answer the number of indexable variables in the receiver. This value is the same as the largest legal subscript. Essential. See Object documentation whatIsAPrimitive. Override the default primitive to give latitude to the VM in context management." <primitive: 212> "The number of indexable fields of fixed-length objects is 0" ^self primitiveFail! ----- Method: Context>>sourceCode (in category 'debugger access') ----- sourceCode ^method getSource "Note: The above is a bit safer than ^ methodClass sourceCodeAt: selector which may fail if the receiver's method has been changed in the debugger (e.g., the method is no longer in the methodDict and thus the above selector is something like #Doit:with:with:with:) but the source code is still available."! ----- Method: Context>>stack (in category 'debugger access') ----- stack "Answer an Array of the contexts on the receiver's sender chain." ^self stackOfSize: 9999! ----- Method: Context>>stackOfSize: (in category 'debugger access') ----- stackOfSize: limit "Answer an OrderedCollection of the top 'limit' contexts on the receiver's sender chain." | stack ctxt | stack := OrderedCollection new. stack addLast: (ctxt := self). [(ctxt := ctxt sender) ~~ nil and: [stack size < limit]] whileTrue: [stack addLast: ctxt]. ^stack! ----- Method: Context>>stackPtr (in category 'private') ----- stackPtr "For use only by the SystemTracer and the Debugger, Inspectors etc" ^ stackp! ----- Method: Context>>stackp: (in category 'private') ----- stackp: newStackp "Storing into the stack pointer is a potentially dangerous thing. This primitive stores nil into any cells that become accessible as a result, and it performs the entire operation atomically." "Once this primitive is implemented, failure code should cause an error" <primitive: 76> self error: 'stackp store failure'. " stackp == nil ifTrue: [stackp := 0]. newStackp > stackp 'effectively checks that it is a number' ifTrue: [oldStackp := stackp. stackp := newStackp. 'Nil any newly accessible cells' oldStackp + 1 to: stackp do: [:i | self at: i put: nil]] ifFalse: [stackp := newStackp] "! ----- Method: Context>>startpc (in category 'private') ----- startpc ^closureOrNil ifNil: [method initialPC] ifNotNil: [closureOrNil startpc]! ----- Method: Context>>step (in category 'system simulation') ----- step "Simulate the execution of the receiver's next bytecode. Answer the context that would be the active context after this bytecode." ^self interpretNextInstructionFor: self! ----- Method: Context>>stepToCallee (in category 'system simulation') ----- stepToCallee "Step to callee or sender" | ctxt | ctxt := self. [(ctxt := ctxt step) == self] whileTrue. ^ ctxt! ----- Method: Context>>stepToSendOrReturn (in category 'system simulation') ----- stepToSendOrReturn "Simulate the execution of bytecodes until either sending a message or returning a value to the receiver (that is, until switching contexts)." | ctxt | [self willReallySend | self willReturn | self willStore] whileFalse: [ ctxt := self step. ctxt == self ifFalse: [self halt. "Caused by mustBeBoolean handling" ^ctxt]]! ----- Method: Context>>storeDataOn: (in category 'objects from disk') ----- storeDataOn: aDataStream "Contexts are not allowed go to out in DataStreams. They must be included inside an ImageSegment." aDataStream insideASegment ifTrue: [^ super storeDataOn: aDataStream]. self error: 'This Context was not included in the ImageSegment'. "or perhaps ImageSegments were not used at all" ^ nil! ----- Method: Context>>storeIntoLiteralVariable: (in category 'instruction decoding') ----- storeIntoLiteralVariable: value "Simulate the action of bytecode that stores the top of the stack into a literal variable of my method." self object: value instVarAt: ValueIndex put: self top! ----- Method: Context>>storeIntoReceiverVariable: (in category 'instruction decoding') ----- storeIntoReceiverVariable: offset "Simulate the action of bytecode that stores the top of the stack into an instance variable of my receiver." self object: receiver instVarAt: offset + 1 put: self top! ----- Method: Context>>storeIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') ----- storeIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex "Simulate the action of bytecode that stores the top of the stack at an offset in one of my local variables being used as a remote temp vector." self object: (self at: tempVectorIndex + 1) basicAt: remoteTempIndex + 1 put: self top! ----- Method: Context>>storeIntoTemporaryVariable: (in category 'instruction decoding') ----- storeIntoTemporaryVariable: offset "Simulate the action of bytecode that stores the top of the stack into one of my temporary variables." self at: offset + 1 put: self top! ----- Method: Context>>swapReceiver: (in category 'private-exceptions') ----- swapReceiver: r receiver := r! ----- Method: Context>>swapSender: (in category 'debugger access') ----- swapSender: coroutine "Replace the receiver's sender with coroutine and answer the receiver's previous sender. For use in coroutining." | oldSender | oldSender := sender. sender := coroutine. ^oldSender! ----- Method: Context>>tempAt: (in category 'accessing') ----- tempAt: index "Answer the value of the temporary variable whose index is the argument, 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. Override the default at: primitive to give latitude to the VM in context management." <primitive: 210> ^self at: index! ----- Method: Context>>tempAt:put: (in category 'accessing') ----- tempAt: index put: value "Store the argument, value, as the temporary variable whose index is the argument, 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. Override the default at:put: primitive to give latitude to the VM in context management." <primitive: 211> ^self at: index put: value! ----- Method: Context>>tempNames (in category 'debugger access') ----- tempNames "Answer a SequenceableCollection of the names of the receiver's temporary variables, which are strings." ^ self debuggerMap tempNamesForContext: self! ----- Method: Context>>tempsAndValues (in category 'debugger access') ----- tempsAndValues "Return a string of the temporary variabls and their current values" ^self debuggerMap tempsAndValuesForContext: self! ----- Method: Context>>tempsAndValuesLimitedTo:indent: (in category 'debugger access') ----- tempsAndValuesLimitedTo: sizeLimit indent: indent "Return a string of the temporary variabls and their current values" | aStream | aStream := WriteStream on: (String new: 100). self tempNames doWithIndex: [:title :index | indent timesRepeat: [aStream tab]. aStream nextPutAll: title; nextPut: $:; space; tab. aStream nextPutAll: ((self tempAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1)). aStream cr]. ^aStream contents! ----- Method: Context>>terminate (in category 'controlling') ----- terminate "Make myself unresumable." sender := nil. pc := nil. ! ----- Method: Context>>terminateTo: (in category 'controlling') ----- terminateTo: previousContext "Terminate all the Contexts between me and previousContext, if previousContext is on my Context stack. Make previousContext my sender." | currentContext sendingContext | <primitive: 196> (self hasSender: previousContext) ifTrue: [ currentContext := sender. [currentContext == previousContext] whileFalse: [ sendingContext := currentContext sender. currentContext terminate. currentContext := sendingContext]]. sender := previousContext! ----- Method: Context>>top (in category 'controlling') ----- top "Answer the top of the receiver's stack." ^self at: stackp! ----- Method: Context>>tryNamedPrimitiveIn:for:withArgs: (in category 'private') ----- tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments "Invoke the named primitive for aCompiledMethod, answering its result, or, if the primiitve fails, answering the error code." <primitive: 218 error: ec> ec ifNotNil: ["If ec is an integer other than -1 there was a problem with primitive 218, not with the external primitive itself. -1 indicates a generic failure (where ec should be nil) but ec = nil means primitive 218 is not implemented. So interpret -1 to mean the external primitive failed with a nil error code." ec isInteger ifTrue: [ec = -1 ifTrue: [ec := nil] ifFalse: [self primitiveFailed]]]. ^self class primitiveFailTokenFor: ec! ----- Method: Context>>tryPrimitiveFor:receiver:args: (in category 'private') ----- tryPrimitiveFor: method receiver: receiver args: arguments "If this method has a primitive index, then run the primitive and return its result. Otherwise (and also if the primitive fails) return PrimitiveFailToken, as an indication that the method should be activated and run as bytecodes." | primIndex | (primIndex := method primitive) = 0 ifTrue: [^{PrimitiveFailToken. nil}]. ^ self doPrimitive: primIndex method: method receiver: receiver args: arguments! ----- Method: Context>>unwindTo: (in category 'private-exceptions') ----- unwindTo: aContext | ctx unwindBlock | ctx := self. [(ctx := ctx findNextUnwindContextUpTo: aContext) isNil] whileFalse: [ (ctx tempAt: 2) ifNil:[ ctx tempAt: 2 put: true. unwindBlock := ctx tempAt: 1. unwindBlock value] ]. !

1 0

VM Maker: CogBenchmarks-eem.1.mcz
by commits＠source.squeak.org 03 Sep '14

03 Sep '14

Eliot Miranda uploaded a new version of CogBenchmarks to project VM Maker: http://source.squeak.org/VMMaker/CogBenchmarks-eem.1.mcz ==================== Summary ==================== Name: CogBenchmarks-eem.1 Author: eem Time: 3 September 2014, 10:02:40.405 am UUID: 5bb3e9ae-f915-4f72-94f0-1b09062e7f44 Ancestors: Move the Cog benchmarks to their own package. ==================== Snapshot ==================== SystemOrganization addCategory: #'CogBenchmarks-DeltaBlue'! SystemOrganization addCategory: #'CogBenchmarks-Richards'! SystemOrganization addCategory: #'CogBenchmarks-SMark'! SystemOrganization addCategory: #'CogBenchmarks-Shootout'! Object subclass: #DBAbstractConstraint instanceVariableNames: 'strength' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-DeltaBlue'! !DBAbstractConstraint commentStamp: '<historical>' prior: 0! I am an abstract class representing a system-maintainable relationship (or "constraint") between a set of variables. I supply a strength instance variable; concrete subclasses provide a means of storing the constrained variables and other information required to represent a constraint. Instance variables: strength the strength of this constraint <Strength>! ----- Method: DBAbstractConstraint>>addConstraint (in category 'adding') ----- addConstraint "Activate this constraint and attempt to satisfy it." self addToGraph. DBPlanner current incrementalAdd: self.! ----- Method: DBAbstractConstraint>>addToGraph (in category 'adding') ----- addToGraph "Add myself to the constraint graph." self subclassResponsibility! ----- Method: DBAbstractConstraint>>chooseMethod: (in category 'planning') ----- chooseMethod: mark "Decide if I can be satisfied and record that decision. The output of the choosen method must not have the given mark and must have a walkabout strength less than that of this constraint." self subclassResponsibility! ----- Method: DBAbstractConstraint>>destroyConstraint (in category 'adding') ----- destroyConstraint "Deactivate this constraint, remove it from the constraint graph, possibly causing other constraints to be satisfied, and destroy it." (self isSatisfied) ifTrue: [DBPlanner current incrementalRemove: self]. self removeFromGraph. self release.! ----- Method: DBAbstractConstraint>>execute (in category 'planning') ----- execute "Enforce this constraint. Assume that it is satisfied." self subclassResponsibility! ----- Method: DBAbstractConstraint>>inputsDo: (in category 'planning') ----- inputsDo: aBlock "Assume that I am satisfied. Evaluate the given block on all my current input variables." self subclassResponsibility! ----- Method: DBAbstractConstraint>>inputsKnown: (in category 'planning') ----- inputsKnown: mark "Assume that I am satisfied. Answer true if all my current inputs are known. A variable is known if either a) it is 'stay' (i.e. it is a constant at plan execution time), b) it has the given mark (indicating that it has been computed by a constraint appearing earlier in the plan), or c) it is not determined by any constraint." self inputsDo: [ :v | (v mark = mark or: [v stay or: [v determinedBy isNil]]) ifFalse: [^false]]. ^true! ----- Method: DBAbstractConstraint>>isInput (in category 'testing') ----- isInput "Normal constraints are not input constraints. An input constraint is one that depends on external state, such as the mouse, the keyboard, a clock, or some arbitrary piece of imperative code." ^false! ----- Method: DBAbstractConstraint>>isSatisfied (in category 'testing') ----- isSatisfied "Answer true if this constraint is satisfied in the current solution." self subclassResponsibility! ----- Method: DBAbstractConstraint>>longPrintOn: (in category 'printing') ----- longPrintOn: aStream aStream nextPut: $(. self shortPrintOn: aStream. aStream space; nextPutAll: self strength printString. (self isSatisfied) ifTrue: [aStream cr; space; space; space. self inputsDo: [ :in | aStream nextPutAll: 'v', in printString, ' ']. aStream nextPutAll: '-> '. aStream nextPutAll: 'v', self output printString] ifFalse: [aStream space; nextPutAll: 'UNSATISFIED']. aStream nextPut: $); cr.! ----- Method: DBAbstractConstraint>>markUnsatisfied (in category 'planning') ----- markUnsatisfied "Record the fact that I am unsatisfied." self subclassResponsibility! ----- Method: DBAbstractConstraint>>output (in category 'planning') ----- output "Answer my current output variable. Raise an error if I am not currently satisfied." self subclassResponsibility! ----- Method: DBAbstractConstraint>>printOn: (in category 'printing') ----- printOn: aStream self shortPrintOn: aStream! ----- Method: DBAbstractConstraint>>recalculate (in category 'planning') ----- recalculate "Calculate the walkabout strength, the stay flag, and, if it is 'stay', the value for the current output of this constraint. Assume this constraint is satisfied." self subclassResponsibility! ----- Method: DBAbstractConstraint>>removeFromGraph (in category 'adding') ----- removeFromGraph "Remove myself from the constraint graph." self subclassResponsibility! ----- Method: DBAbstractConstraint>>satisfy: (in category 'planning') ----- satisfy: mark "Attempt to find a way to enforce this (still unsatisfied) constraint. If successful, record the solution, perhaps modifying the current dataflow graph. Answer the constraint that this constraint overrides, if there is one, or nil, if there isn't." | overridden out | self chooseMethod: mark. self isSatisfied ifTrue: "constraint can be satisfied" ["mark inputs to allow cycle detection in addPropagate" self inputsDo: [ :in | in mark: mark]. out := self output. overridden := out determinedBy. overridden ifNotNil: [overridden markUnsatisfied]. out determinedBy: self. (DBPlanner current addPropagate: self mark: mark) ifFalse: [self notify: ('Cycle encountered adding:\ ', self printString, '\Constraint removed.') withCRs. ^nil]. out mark: mark] ifFalse: "constraint cannot be satisfied" [overridden := nil. (strength sameAs: (DBStrength required)) ifTrue: [self notify: 'Failed to satisfy a required constraint']]. ^ overridden! ----- Method: DBAbstractConstraint>>shortPrintOn: (in category 'printing') ----- shortPrintOn: aStream aStream nextPutAll: self class name, '(', self printString, ')'.! ----- Method: DBAbstractConstraint>>strength (in category 'accessing') ----- strength ^ strength! ----- Method: DBAbstractConstraint>>strength: (in category 'accessing') ----- strength: anObject strength := anObject! DBAbstractConstraint subclass: #DBBinaryConstraint instanceVariableNames: 'direction v1 v2' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-DeltaBlue'! !DBBinaryConstraint commentStamp: '<historical>' prior: 0! I am an abstract superclass for constraints having two possible output variables. Instance variables: v1, v2 possible output variables <Variable> direction one of: #forward (v2 is output) #backward ( v1 is output) nil (not satisfied)! ----- Method: DBBinaryConstraint class>>var:var:strength: (in category 'instance creation') ----- var: variable1 var: variable2 strength: strengthSymbol "Install a constraint with the given strength equating the given variables." ^(self new) var: variable1 var: variable2 strength: strengthSymbol! ----- Method: DBBinaryConstraint>>addToGraph (in category 'adding') ----- addToGraph "Add myself to the constraint graph." v1 addConstraint: self. v2 addConstraint: self. direction := nil.! ----- Method: DBBinaryConstraint>>chooseMethod: (in category 'planning') ----- chooseMethod: mark "Decide if I can be satisfied and which way I should flow based on the relative strength of the variables I relate, and record that decision." v1 mark == mark ifTrue: "forward or nothing" [ ^ direction := ((v2 mark ~= mark) and: [strength stronger: v2 walkStrength]) ifTrue: [ #forward ] ifFalse: [ nil ] ]. v2 mark == mark ifTrue: "backward or nothing" [ ^ direction := ((v1 mark ~= mark) and: [strength stronger: v1 walkStrength]) ifTrue: [ #backward ] ifFalse: [ nil ] ]. "if we get here, neither variable is marked, so we have choice" (v1 walkStrength weaker: v2 walkStrength) ifTrue: [ ^ direction := (strength stronger: v1 walkStrength) ifTrue: [ #backward ] ifFalse: [ nil ]] ifFalse: [ ^ direction := (strength stronger: v2 walkStrength) ifTrue: [ #forward ] ifFalse: [ nil ]]. ! ----- Method: DBBinaryConstraint>>execute (in category 'planning') ----- execute "Enforce this constraint. Assume that it is satisfied." self subclassResponsibility! ----- Method: DBBinaryConstraint>>inputsDo: (in category 'planning') ----- inputsDo: aBlock "Evaluate the given block on my current input variable." direction == #forward ifTrue: [ aBlock value: v1 ] ifFalse: [ aBlock value: v2 ].! ----- Method: DBBinaryConstraint>>isSatisfied (in category 'testing') ----- isSatisfied "Answer true if this constraint is satisfied in the current solution." ^ direction notNil! ----- Method: DBBinaryConstraint>>markUnsatisfied (in category 'planning') ----- markUnsatisfied "Record the fact that I am unsatisfied." direction := nil.! ----- Method: DBBinaryConstraint>>output (in category 'planning') ----- output "Answer my current output variable." ^ direction == #forward ifTrue: [ v2 ] ifFalse: [ v1 ]! ----- Method: DBBinaryConstraint>>recalculate (in category 'planning') ----- recalculate "Calculate the walkabout strength, the stay flag, and, if it is 'stay', the value for the current output of this constraint. Assume this constraint is satisfied." | in out | direction == #forward ifTrue: [in := v1. out := v2] ifFalse: [in := v2. out := v1]. out walkStrength: (strength weakest: in walkStrength). out stay: in stay. out stay ifTrue: [ self execute ]. "stay optimization"! ----- Method: DBBinaryConstraint>>removeFromGraph (in category 'adding') ----- removeFromGraph "Remove myself from the constraint graph." v1 ifNotNil: [v1 removeConstraint: self]. v2 ifNotNil: [v2 removeConstraint: self]. direction := nil.! ----- Method: DBBinaryConstraint>>var:var:strength: (in category 'initialize') ----- var: variable1 var: variable2 strength: strengthSymbol "Initialize myself with the given variables and strength." strength := DBStrength of: strengthSymbol. v1 := variable1. v2 := variable2. direction := nil. self addConstraint.! DBBinaryConstraint subclass: #DBEqualityConstraint instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-DeltaBlue'! !DBEqualityConstraint commentStamp: '<historical>' prior: 0! I constrain two variables to have the same value: "v1 = v2".! ----- Method: DBEqualityConstraint>>execute (in category 'planning') ----- execute "Enforce this constraint. Assume that it is satisfied." direction == #forward ifTrue: [v2 value: v1 value] ifFalse: [v1 value: v2 value].! DBBinaryConstraint subclass: #DBScaleConstraint instanceVariableNames: 'offset scale' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-DeltaBlue'! !DBScaleConstraint commentStamp: '<historical>' prior: 0! I relate two variables by the linear scaling relationship: "v2 = (v1 * scale) + offset". Either v1 or v2 may be changed to maintain this relationship but the scale factor and offset are considered read-only. Instance variables: scale scale factor input variable <Variable> offset offset input variable <Variable>! ----- Method: DBScaleConstraint class>>var:var:var:var:strength: (in category 'instance creation') ----- var: src var: scale var: offset var: dst strength: strengthSymbol "Install a scale constraint with the given strength on the given variables." ^(self new) src: src scale: scale offset: offset dst: dst strength: strengthSymbol! ----- Method: DBScaleConstraint>>addToGraph (in category 'adding') ----- addToGraph "Add myself to the constraint graph." super addToGraph. scale addConstraint: self. offset addConstraint: self. ! ----- Method: DBScaleConstraint>>execute (in category 'planning') ----- execute "Enforce this constraint. Assume that it is satisfied." direction == #forward ifTrue: [v2 value: v1 value * scale value + offset value] ifFalse: [v1 value: v2 value - offset value // scale value].! ----- Method: DBScaleConstraint>>inputsDo: (in category 'planning') ----- inputsDo: aBlock "Evaluate the given block on my current input variable." direction == #forward ifTrue: [ aBlock value: v1; value: scale; value: offset] ifFalse: [ aBlock value: v2; value: scale; value: offset].! ----- Method: DBScaleConstraint>>recalculate (in category 'planning') ----- recalculate "Calculate the walkabout strength, the stay flag, and, if it is 'stay', the value for the current output of this constraint. Assume this constraint is satisfied." | in out | direction == #forward ifTrue: [in := v1. out := v2] ifFalse: [out := v1. in := v2]. out walkStrength: (strength weakest: in walkStrength). out stay: (in stay and: [scale stay and: [offset stay]]). out stay ifTrue: [self execute]. "stay optimization"! ----- Method: DBScaleConstraint>>removeFromGraph (in category 'adding') ----- removeFromGraph "Remove myself from the constraint graph." super removeFromGraph. scale ifNotNil: [scale removeConstraint: self]. offset ifNotNil: [offset removeConstraint: self]. ! ----- Method: DBScaleConstraint>>src:scale:offset:dst:strength: (in category 'initialize') ----- src: srcVar scale: scaleVar offset: offsetVar dst: dstVar strength: strengthSymbol "Initialize myself with the given variables and strength." strength := DBStrength of: strengthSymbol. v1 := srcVar. v2 := dstVar. scale := scaleVar. offset := offsetVar. direction := nil. self addConstraint.! DBAbstractConstraint subclass: #DBUnaryConstraint instanceVariableNames: 'output satisfied' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-DeltaBlue'! !DBUnaryConstraint commentStamp: '<historical>' prior: 0! I am an abstract superclass for constraints having a single possible output variable. Instance variables: output possible output variable <Variable> satisfied true if I am currently satisfied <Boolean>! DBUnaryConstraint subclass: #DBEditConstraint instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-DeltaBlue'! !DBEditConstraint commentStamp: '<historical>' prior: 0! I mark variables that should, with some level of preference, stay the same. I have one method with zero inputs and one output, which does nothing. Planners may exploit the fact that, if I am satisfied, my output will not change during plan execution. This is called "stay optimization."! ----- Method: DBEditConstraint>>execute (in category 'planning') ----- execute "Edit constraints do nothing."! ----- Method: DBEditConstraint>>isInput (in category 'testing') ----- isInput "I indicate that a variable is to be changed by imperative code." ^true! DBUnaryConstraint subclass: #DBStayConstraint instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-DeltaBlue'! !DBStayConstraint commentStamp: '<historical>' prior: 0! I mark variables that should, with some level of preference, stay the same. I have one method with zero inputs and one output, which does nothing. Planners may exploit the fact that, if I am satisfied, my output will not change during plan execution. This is called "stay optimization."! ----- Method: DBStayConstraint>>execute (in category 'planning') ----- execute "Stay constraints do nothing."! ----- Method: DBUnaryConstraint class>>var:strength: (in category 'instance creation') ----- var: aVariable strength: strengthSymbol "Install an edit constraint with the given strength on the given variable." ^(self new) var: aVariable strength: strengthSymbol! ----- Method: DBUnaryConstraint>>addToGraph (in category 'adding') ----- addToGraph "Add myself to the constraint graph." output addConstraint: self. satisfied := false.! ----- Method: DBUnaryConstraint>>chooseMethod: (in category 'planning') ----- chooseMethod: mark "Decide if I can be satisfied and record that decision." satisfied := output mark ~= mark and: [strength stronger: output walkStrength].! ----- Method: DBUnaryConstraint>>execute (in category 'planning') ----- execute "Enforce this constraint. Assume that it is satisfied." self subclassResponsibility! ----- Method: DBUnaryConstraint>>inputsDo: (in category 'planning') ----- inputsDo: aBlock "I have no input variables."! ----- Method: DBUnaryConstraint>>isSatisfied (in category 'testing') ----- isSatisfied "Answer true if this constraint is satisfied in the current solution." ^satisfied! ----- Method: DBUnaryConstraint>>markUnsatisfied (in category 'planning') ----- markUnsatisfied "Record the fact that I am unsatisfied." satisfied := false.! ----- Method: DBUnaryConstraint>>output (in category 'planning') ----- output "Answer my current output variable." ^ output! ----- Method: DBUnaryConstraint>>recalculate (in category 'planning') ----- recalculate "Calculate the walkabout strength, the stay flag, and, if it is 'stay', the value for the current output of this constraint. Assume this constraint is satisfied." output walkStrength: strength. output stay: self isInput not. output stay ifTrue: [self execute]. "stay optimization"! ----- Method: DBUnaryConstraint>>removeFromGraph (in category 'adding') ----- removeFromGraph "Remove myself from the constraint graph." output ifNotNil: [ :out | out removeConstraint: self]. satisfied := false.! ----- Method: DBUnaryConstraint>>var:strength: (in category 'initialize') ----- var: aVariable strength: strengthSymbol "Initialize myself with the given variable and strength." strength := DBStrength of: strengthSymbol. output := aVariable. satisfied := false. self addConstraint.! Object subclass: #DBPlanner instanceVariableNames: 'currentMark' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-DeltaBlue'! DBPlanner class instanceVariableNames: 'currentPlanner'! !DBPlanner commentStamp: '<historical>' prior: 0! This benchmark is an implementation of the DeltaBlue Constraint Solver described in `The DeltaBlue Algorithm: An Incremental Constraint Hierarchy Solver'', by Bjorn N. Freeman-Benson and John Maloney, Communications of the ACM, January 1990 (also as University of Washington TR 89-08-06). ! DBPlanner class instanceVariableNames: 'currentPlanner'! ----- Method: DBPlanner class>>current (in category 'accessing') ----- current ^ currentPlanner! ----- Method: DBPlanner class>>new (in category 'instance creation') ----- new ^ currentPlanner := super new! ----- Method: DBPlanner>>addConstraintsConsuming:to: (in category 'private') ----- addConstraintsConsuming: v to: aCollection | determiningC | determiningC := v determinedBy. v constraints do: [ :c | (c == determiningC or: [c isSatisfied not]) ifFalse: [aCollection add: c]].! ----- Method: DBPlanner>>addPropagate:mark: (in category 'private') ----- addPropagate: c mark: mark "Recompute the walkabout strengths and stay flags of all variables downstream of the given constraint and recompute the actual values of all variables whose stay flag is true. If a cycle is detected, remove the given constraint and answer false. Otherwise, answer true. Details: Cycles are detected when a marked variable is encountered downstream of the given constraint. The sender is assumed to have marked the inputs of the given constraint with the given mark. Thus, encountering a marked node downstream of the output constraint means that there is a path from the constraint's output to one of its inputs." | todo d | todo := OrderedCollection with: c. [todo isEmpty] whileFalse: [d := todo removeFirst. (d output mark = mark) ifTrue: [self incrementalRemove: c. ^ false]. d recalculate. self addConstraintsConsuming: d output to: todo]. ^ true! ----- Method: DBPlanner>>changeVar:newValue: (in category 'private') ----- changeVar: aVariable newValue: newValue | editConstraint plan | editConstraint := DBEditConstraint var: aVariable strength: #preferred. plan := self extractPlanFromConstraints: (Array with: editConstraint). 10 timesRepeat: [ aVariable value: newValue. plan execute]. editConstraint destroyConstraint.! ----- Method: DBPlanner>>constraintsConsuming:do: (in category 'private') ----- constraintsConsuming: v do: aBlock | determiningC | determiningC := v determinedBy. v constraints do: [ :c | (c == determiningC or: [c isSatisfied not]) ifFalse: [aBlock value: c]].! ----- Method: DBPlanner>>extractPlanFromConstraints: (in category 'planning') ----- extractPlanFromConstraints: constraints "Extract a plan for resatisfaction starting from the outputs of the given constraints, usually a set of input constraints." | sources | sources := OrderedCollection new. constraints do: [: c | (c isInput and: [c isSatisfied]) ifTrue: [sources add: c]]. ^self makePlan: sources! ----- Method: DBPlanner>>extractPlanFromVariables: (in category 'planning') ----- extractPlanFromVariables: variables "Extract a plan from the dataflow graph having the given variables. It is assumed that the given set of variables is complete, or at least that it contains all the input variables." | sources | sources := OrderedCollection new. variables do: [: v | (v constraints) do: [: c | (c isInput and: [c isSatisfied]) ifTrue: [sources add: c]]]. ^self makePlan: sources! ----- Method: DBPlanner>>incrementalAdd: (in category 'adding') ----- incrementalAdd: c "Attempt to satisfy the given constraint and, if successful, incrementally update the dataflow graph. Details: If satifying the constraint is successful, it may override a weaker constraint on its output. The algorithm attempts to resatisfy that constraint using some other method. This process is repeated until either a) it reaches a variable that was not previously determined by any constraint or b) it reaches a constraint that is too weak to be satisfied using any of its methods. The variables of constraints that have been processed are marked with a unique mark value so that we know where we've been. This allows the algorithm to avoid getting into an infinite loop even if the constraint graph has an inadvertent cycle." | mark overridden | mark := self newMark. overridden := c satisfy: mark. [overridden isNil] whileFalse: [overridden := overridden satisfy: mark].! ----- Method: DBPlanner>>incrementalRemove: (in category 'adding') ----- incrementalRemove: c "Entry point for retracting a constraint. Remove the given constraint, which should be satisfied, and incrementally update the dataflow graph. Details: Retracting the given constraint may allow some currently unsatisfiable downstream constraint be satisfied. We thus collect a list of unsatisfied downstream constraints and attempt to satisfy each one in turn. This list is sorted by constraint strength, strongest first, as a heuristic for avoiding unnecessarily adding and then overriding weak constraints." | out unsatisfied | out := c output. c markUnsatisfied. c removeFromGraph. unsatisfied := self removePropagateFrom: out. unsatisfied do: [: u | self incrementalAdd: u].! ----- Method: DBPlanner>>initialize (in category 'initialize') ----- initialize super initialize. currentMark := 1.! ----- Method: DBPlanner>>makePlan: (in category 'planning') ----- makePlan: sources "Extract a plan for resatisfaction starting from the given satisfied source constraints, usually a set of input constraints. This method assumes that stay optimization is desired; the plan will contain only constraints whose output variables are not stay. Constraints that do no computation, such as stay and edit constraints, are not included in the plan. Details: The outputs of a constraint are marked when it is added to the plan under construction. A constraint may be appended to the plan when all its input variables are known. A variable is known if either a) the variable is marked (indicating that has been computed by a constraint appearing earlier in the plan), b) the variable is 'stay' (i.e. it is a constant at plan execution time), or c) the variable is not determined by any constraint. The last provision is for past states of history variables, which are not stay but which are also not computed by any constraint." | mark plan todo c | mark := self newMark. plan := DBPlan new. todo := sources. [todo isEmpty] whileFalse: [c := todo removeFirst. ((c output mark ~= mark) and: "not in plan already and..." [c inputsKnown: mark]) ifTrue: "eligible for inclusion" [plan addLast: c. c output mark: mark. self addConstraintsConsuming: c output to: todo]]. ^ plan! ----- Method: DBPlanner>>newMark (in category 'private') ----- newMark "Select a previously unused mark value. Details: We just keep incrementing. If necessary, the counter will turn into a LargePositiveInteger. In that case, it will be a bit slower to compute the next mark but the algorithms will all behave correctly. We reserve the value '0' to mean 'unmarked'. Thus, this generator starts at '1' and will never produce '0' as a mark value." ^currentMark := currentMark + 1! ----- Method: DBPlanner>>propagateFrom: (in category 'planning') ----- propagateFrom: v "The given variable has changed. Propagate new values downstream." | todo c | todo := OrderedCollection new. self addConstraintsConsuming: v to: todo. [todo isEmpty] whileFalse: [c := todo removeFirst. c execute. self addConstraintsConsuming: c output to: todo].! ----- Method: DBPlanner>>removePropagateFrom: (in category 'private') ----- removePropagateFrom: out "Update the walkabout strengths and stay flags of all variables downstream of the given constraint. Answer a collection of unsatisfied constraints sorted in order of decreasing strength." | unsatisfied todo v | unsatisfied := SortedCollection sortBlock: [ :c1 :c2 | c1 strength stronger: c2 strength]. out determinedBy: nil. out walkStrength: DBStrength absoluteWeakest. out stay: true. todo := OrderedCollection with: out. [todo isEmpty] whileFalse: [v := todo removeFirst. v constraints do: [ :c | c isSatisfied ifFalse: [unsatisfied add: c]]. self constraintsConsuming: v do: [ :c | c recalculate. todo add: c output]]. ^ unsatisfied! Object subclass: #DBStrength instanceVariableNames: 'symbolicValue arithmeticValue' classVariableNames: 'AbsoluteStrongest AbsoluteWeakest Required StrengthConstants StrengthTable' poolDictionaries: '' category: 'CogBenchmarks-DeltaBlue'! !DBStrength commentStamp: '<historical>' prior: 0! Strengths are used to measure the relative importance of constraints. The hierarchy of available strengths is determined by the class variable StrengthTable (see my class initialization method). Because Strengths are invariant, references to Strength instances are shared (i.e. all references to "Strength of: #required" point to a single, shared instance). New strengths may be inserted in the strength hierarchy without disrupting current constraints. Instance variables: symbolicValue symbolic strength name (e.g. #required) <Symbol> arithmeticValue index of the constraint in the hierarchy, used for comparisons <Number>! ----- Method: DBStrength class>>absoluteStrongest (in category 'constants') ----- absoluteStrongest ^AbsoluteStrongest! ----- Method: DBStrength class>>absoluteWeakest (in category 'constants') ----- absoluteWeakest ^AbsoluteWeakest! ----- Method: DBStrength class>>initialize (in category 'initialize') ----- initialize "Initialize the symbolic strength table. Fix the internally caches values of all existing instances." "Strength initialize" StrengthTable := Dictionary new. StrengthTable at: #absoluteStrongest put: -10000. StrengthTable at: #required put: -800. StrengthTable at: #strongPreferred put: -600. StrengthTable at: #preferred put: -400. StrengthTable at: #strongDefault put: -200. StrengthTable at: #default put: 0. StrengthTable at: #weakDefault put: 500. StrengthTable at: #absoluteWeakest put: 10000. StrengthConstants := Dictionary new. StrengthTable keys do: [: strengthSymbol | StrengthConstants at: strengthSymbol put: ((super new) initializeWith: strengthSymbol)]. AbsoluteStrongest := DBStrength of: #absoluteStrongest. AbsoluteWeakest := DBStrength of: #absoluteWeakest. Required := DBStrength of: #required.! ----- Method: DBStrength class>>of: (in category 'instance creation') ----- of: aSymbol "Answer an instance with the specified strength." ^ StrengthConstants at: aSymbol! ----- Method: DBStrength class>>required (in category 'constants') ----- required ^Required! ----- Method: DBStrength>>arithmeticValue (in category 'private') ----- arithmeticValue "Answer my arithmetic value. Used for comparisons. Note that STRONGER constraints have SMALLER arithmetic values." ^arithmeticValue! ----- Method: DBStrength>>initializeWith: (in category 'private') ----- initializeWith: symVal "Record my symbolic value and reset my arithmetic value." symbolicValue := symVal. arithmeticValue := StrengthTable at: symbolicValue.! ----- Method: DBStrength>>printOn: (in category 'printing') ----- printOn: aStream "Append a string which represents my strength onto aStream." aStream nextPutAll: '%', symbolicValue, '%'.! ----- Method: DBStrength>>sameAs: (in category 'comparing') ----- sameAs: aStrength "Answer true if I am the same strength as the given Strength." ^ arithmeticValue = aStrength arithmeticValue! ----- Method: DBStrength>>stronger: (in category 'comparing') ----- stronger: aStrength "Answer true if I am stronger than the given Strength." ^ arithmeticValue < aStrength arithmeticValue! ----- Method: DBStrength>>strongest: (in category 'max / min') ----- strongest: aStrength "Answer the stronger of myself and aStrength." ^ (aStrength stronger: self) ifTrue: [aStrength] ifFalse: [self]! ----- Method: DBStrength>>weaker: (in category 'comparing') ----- weaker: aStrength "Answer true if I am weaker than the given Strength." ^ arithmeticValue > aStrength arithmeticValue! ----- Method: DBStrength>>weakest: (in category 'max / min') ----- weakest: aStrength "Answer the weaker of myself and aStrength." ^ (aStrength weaker: self) ifTrue: [aStrength] ifFalse: [self].! Object subclass: #DBVariable instanceVariableNames: 'constraints determinedBy mark stay value walkStrength' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-DeltaBlue'! !DBVariable commentStamp: '<historical>' prior: 0! I represent a constrained variable. In addition to my value, I maintain the structure of the constraint graph, the current dataflow graph, and various parameters of interest to the DeltaBlue incremental constraint solver. Instance variables: value my value; changed by constraints, read by client <Object> constraints normal constraints that reference me <Array of Constraint> determinedBy the constraint that currently determines my value (or nil if there isn''t one) <Constraint> walkStrength my walkabout strength <Strength> stay true if I am a planning-time constant <Boolean> mark used by the planner to mark constraints <Number>! ----- Method: DBVariable class>>value: (in category 'instance creation') ----- value: aValue ^self new value: aValue! ----- Method: DBVariable>>addConstraint: (in category 'accessing') ----- addConstraint: aConstraint "Add the given constraint to the set of all constraints that refer to me." constraints add: aConstraint.! ----- Method: DBVariable>>constraints (in category 'accessing') ----- constraints ^ constraints! ----- Method: DBVariable>>determinedBy (in category 'accessing') ----- determinedBy ^ determinedBy! ----- Method: DBVariable>>determinedBy: (in category 'accessing') ----- determinedBy: anObject determinedBy := anObject! ----- Method: DBVariable>>initialize (in category 'initialize') ----- initialize super initialize. value := 0. constraints := OrderedCollection new: 2. determinedBy := nil. walkStrength := DBStrength absoluteWeakest. stay := true. mark := 0.! ----- Method: DBVariable>>longPrintOn: (in category 'printing') ----- longPrintOn: aStream self shortPrintOn: aStream. aStream nextPutAll: ' Constraints: '. (constraints isEmpty) ifTrue: [aStream cr; tab; nextPutAll: 'none'] ifFalse: [constraints do: [: c | aStream cr; tab. c shortPrintOn: aStream]]. (determinedBy isNil) ifFalse: [aStream cr; nextPutAll: ' Determined by: '. aStream cr; tab. determinedBy shortPrintOn: aStream]. aStream cr.! ----- Method: DBVariable>>mark (in category 'accessing') ----- mark ^ mark! ----- Method: DBVariable>>mark: (in category 'accessing') ----- mark: anObject mark := anObject! ----- Method: DBVariable>>printOn: (in category 'printing') ----- printOn: aStream self shortPrintOn: aStream! ----- Method: DBVariable>>removeConstraint: (in category 'accessing') ----- removeConstraint: c "Remove all traces of c from this variable." constraints remove: c ifAbsent: []. determinedBy == c ifTrue: [determinedBy := nil].! ----- Method: DBVariable>>setValue: (in category 'update') ----- setValue: aValue "Attempt to assign the given value to me using a strength of #preferred." self setValue: aValue strength: #preferred.! ----- Method: DBVariable>>setValue:strength: (in category 'update') ----- setValue: aValue strength: strengthSymbol "Attempt to assign the given value to me using the given strength." | editConstraint | editConstraint := DBEditConstraint var: self strength: strengthSymbol. (editConstraint isSatisfied) ifTrue: [self value: aValue. DBPlanner propagateFrom: self]. editConstraint destroyConstraint.! ----- Method: DBVariable>>shortPrintOn: (in category 'printing') ----- shortPrintOn: aStream aStream nextPutAll: 'V(', self printString, ', '. aStream nextPutAll: walkStrength printString, ', '. (stay isNil) ifFalse: [aStream nextPutAll: (stay ifTrue: ['stay, '] ifFalse: ['changing, '])]. aStream nextPutAll: value printString. aStream nextPutAll: ')'. aStream cr.! ----- Method: DBVariable>>stay (in category 'accessing') ----- stay ^ stay! ----- Method: DBVariable>>stay: (in category 'accessing') ----- stay: anObject stay := anObject! ----- Method: DBVariable>>value (in category 'accessing') ----- value ^ value! ----- Method: DBVariable>>value: (in category 'accessing') ----- value: anObject value := anObject! ----- Method: DBVariable>>walkStrength (in category 'accessing') ----- walkStrength ^ walkStrength! ----- Method: DBVariable>>walkStrength: (in category 'accessing') ----- walkStrength: anObject walkStrength := anObject! Object subclass: #RichObject instanceVariableNames: '' classVariableNames: 'DeviceA DeviceB DevicePacketKind HandlerA HandlerB Idler WorkPacketKind Worker' poolDictionaries: '' category: 'CogBenchmarks-Richards'! !RichObject commentStamp: '<historical>' prior: 0! This class mostly adds some constants that are used in the Richards benchmarks.! RichObject subclass: #RichDeviceTaskDataRecord instanceVariableNames: 'pending' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Richards'! !RichDeviceTaskDataRecord commentStamp: '<historical>' prior: 0! A task that suspends itself after each time it has been run to simulate waiting for data from an external device. ! ----- Method: RichDeviceTaskDataRecord>>pending (in category 'accessing') ----- pending ^ pending! ----- Method: RichDeviceTaskDataRecord>>pending: (in category 'accessing') ----- pending: anObject pending := anObject! RichObject subclass: #RichHandlerTaskDataRecord instanceVariableNames: 'workIn deviceIn' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Richards'! !RichHandlerTaskDataRecord commentStamp: '<historical>' prior: 0! A task that manipulates work packets and then suspends itself.! ----- Method: RichHandlerTaskDataRecord>>deviceIn (in category 'accessing') ----- deviceIn ^ deviceIn! ----- Method: RichHandlerTaskDataRecord>>deviceIn: (in category 'accessing') ----- deviceIn: anObject deviceIn := anObject! ----- Method: RichHandlerTaskDataRecord>>deviceInAdd: (in category 'accessing') ----- deviceInAdd: packet deviceIn := self append: packet head: deviceIn! ----- Method: RichHandlerTaskDataRecord>>workIn (in category 'accessing') ----- workIn ^ workIn! ----- Method: RichHandlerTaskDataRecord>>workIn: (in category 'accessing') ----- workIn: anObject workIn := anObject! ----- Method: RichHandlerTaskDataRecord>>workInAdd: (in category 'accessing') ----- workInAdd: packet workIn := self append: packet head: workIn! RichObject subclass: #RichIdleTaskDataRecord instanceVariableNames: 'control count' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Richards'! !RichIdleTaskDataRecord commentStamp: '<historical>' prior: 0! An idle task doesn't do any work itself but cycles control between the two device tasks.! ----- Method: RichIdleTaskDataRecord>>control (in category 'accessing') ----- control ^ control! ----- Method: RichIdleTaskDataRecord>>control: (in category 'accessing') ----- control: anObject control := anObject! ----- Method: RichIdleTaskDataRecord>>count (in category 'accessing') ----- count ^ count! ----- Method: RichIdleTaskDataRecord>>count: (in category 'accessing') ----- count: anObject count := anObject! ----- Method: RichIdleTaskDataRecord>>initialize (in category 'initialize') ----- initialize control := 1. count := 10000! ----- Method: RichObject class>>initialize (in category 'initialize') ----- initialize super initialize. DeviceA := 5. DeviceB := 6. DevicePacketKind := 1. HandlerA := 3. HandlerB := 4. Idler := 1. Worker := 2. WorkPacketKind := 2! ----- Method: RichObject>>append:head: (in category 'utilities') ----- append: packet head: queueHead | mouse link | packet link: nil. queueHead ifNil: [ ^ packet ]. mouse := queueHead. [ (link := mouse link) isNil] whileFalse: [ mouse := link ]. mouse link: packet. ^ queueHead! RichObject subclass: #RichPacket instanceVariableNames: 'data datum identity kind link' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Richards'! !RichPacket commentStamp: '<historical>' prior: 0! A simple package of data that is manipulated by the tasks. The exact layout of the payload data carried by a packet is not importaint, and neither is the nature of the work performed on packets by the tasks. Besides carrying data, packets form linked lists and are hence used both as data and worklists.! ----- Method: RichPacket class>>create:identity:kind: (in category 'instance creation') ----- create: link identity: identity kind: kind ^ self new link: link identity: identity kind: kind! ----- Method: RichPacket>>data (in category 'accessing') ----- data ^ data! ----- Method: RichPacket>>datum (in category 'accessing') ----- datum ^ datum! ----- Method: RichPacket>>datum: (in category 'accessing') ----- datum: anObject datum := anObject! ----- Method: RichPacket>>identity (in category 'accessing') ----- identity ^ identity! ----- Method: RichPacket>>identity: (in category 'accessing') ----- identity: anObject identity := anObject! ----- Method: RichPacket>>kind (in category 'accessing') ----- kind ^ kind! ----- Method: RichPacket>>link (in category 'accessing') ----- link ^ link! ----- Method: RichPacket>>link: (in category 'accessing') ----- link: anObject link := anObject! ----- Method: RichPacket>>link:identity:kind: (in category 'initialize') ----- link: aLink identity: anIdentity kind: aKind link := aLink. identity := anIdentity. kind := aKind. datum := 1. data := ByteArray new: 4! RichObject subclass: #RichRunner instanceVariableNames: 'taskList currentTask currentTaskIdentity taskTable queuePacketCount holdCount' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Richards'! !RichRunner commentStamp: '<historical>' prior: 0! Richards simulates the task dispatcher of an operating system.! ----- Method: RichRunner class>>start (in category 'starting') ----- start "RichardsBenchmark start" ^self new start! ----- Method: RichRunner>>createDevice:priority:work:state: (in category 'creation') ----- createDevice: identity priority: priority work: work state: state | data | data := RichDeviceTaskDataRecord new. self createTask: identity priority: priority work: work state: state function: [:work1 :word | | data1 functionWork | data1 := word. functionWork := work1. functionWork ifNil: [(functionWork := data1 pending) isNil ifTrue: [self wait] ifFalse: [data1 pending: nil. self queuePacket: functionWork]] ifNotNil: [data1 pending: functionWork. self holdSelf]] data: data! ----- Method: RichRunner>>createHandler:priority:work:state: (in category 'creation') ----- createHandler: identity priority: priority work: work state: state | data | data := RichHandlerTaskDataRecord new. self createTask: identity priority: priority work: work state: state function: [:work1 :word | | data1 workPacket count devicePacket | data1 := word. work1 ifNotNil: [WorkPacketKind == work1 kind ifTrue: [data1 workInAdd: work1] ifFalse: [data1 deviceInAdd: work1]]. (workPacket := data1 workIn) ifNil: [self wait] ifNotNil: [count := workPacket datum. count > 4 ifTrue: [data1 workIn: workPacket link. self queuePacket: workPacket] ifFalse: [(devicePacket := data1 deviceIn) ifNil: [self wait] ifNotNil: [data1 deviceIn: devicePacket link. devicePacket datum: (workPacket data at: count). workPacket datum: count + 1. self queuePacket: devicePacket]]]] data: data! ----- Method: RichRunner>>createIdler:priority:work:state: (in category 'creation') ----- createIdler: identity priority: priority work: work state: state | data | data := RichIdleTaskDataRecord new. self createTask: identity priority: priority work: work state: state function: [:work1 :word | | data1 | data1 := word. data1 count: data1 count - 1. 0 = data1 count ifTrue: [self holdSelf] ifFalse: [0 = (data1 control bitAnd: 1) ifTrue: [data1 control: data1 control // 2. self release: DeviceA] ifFalse: [data1 control: (data1 control // 2 bitXor: 53256). self release: DeviceB]]] data: data! ----- Method: RichRunner>>createPacket:identity:kind: (in category 'creation') ----- createPacket: link identity: identity kind: kind ^ RichPacket create: link identity: identity kind: kind! ----- Method: RichRunner>>createTask:priority:work:state:function:data: (in category 'creation') ----- createTask: identity priority: priority work: work state: state function: aBlock data: data | t | t := RichTaskControlBlock link: taskList create: identity priority: priority initialWorkQueue: work initialState: state function: aBlock privateData: data. taskList := t. taskTable at: identity put: t! ----- Method: RichRunner>>createWorker:priority:work:state: (in category 'creation') ----- createWorker: identity priority: priority work: work state: state | data | data := RichWorkerTaskDataRecord new. self createTask: identity priority: priority work: work state: state function: [:work1 :word | | data1 | data1 := word. work1 ifNil: [self wait] ifNotNil: [data1 destination: (HandlerA = data1 destination ifTrue: [HandlerB] ifFalse: [HandlerA]). work1 identity: data1 destination. work1 datum: 1. 1 to: 4 do: [ :i | data1 count: data1 count + 1. data1 count > 26 ifTrue: [data1 count: 1]. work1 data at: i put: $A asInteger + data1 count - 1]. self queuePacket: work1]] data: data! ----- Method: RichRunner>>findTask: (in category 'private') ----- findTask: identity | t | t := taskTable at: identity. t ifNil: [self error: 'findTask failed']. ^ t! ----- Method: RichRunner>>holdSelf (in category 'private') ----- holdSelf holdCount := holdCount + 1. currentTask taskHolding: true. ^ currentTask link! ----- Method: RichRunner>>initScheduler (in category 'private') ----- initScheduler queuePacketCount := holdCount := 0. taskTable := Array new: 6. taskList := nil! ----- Method: RichRunner>>queuePacket: (in category 'private') ----- queuePacket: packet | t | t := self findTask: packet identity. t ifNil: [ ^ nil ]. queuePacketCount := queuePacketCount + 1. packet link: nil. packet identity: currentTaskIdentity. ^ t addInput: packet checkPriority: currentTask! ----- Method: RichRunner>>release: (in category 'private') ----- release: identity | t | t := self findTask: identity. t ifNil: [ ^ nil ]. t taskHolding: false. ^ t priority > currentTask priority ifTrue: [ t ] ifFalse: [ currentTask ]! ----- Method: RichRunner>>schedule (in category 'scheduling') ----- schedule currentTask := taskList. [currentTask isNil] whileFalse: [currentTask isTaskHoldingOrWaiting ifTrue: [currentTask := currentTask link] ifFalse: [currentTaskIdentity := currentTask identity. currentTask := currentTask runTask]]! ----- Method: RichRunner>>start (in category 'initialize') ----- start | workQ | self initScheduler. self createIdler: Idler priority: 0 work: nil state: RichTaskState running. workQ := self createPacket: nil identity: Worker kind: WorkPacketKind. workQ := self createPacket: workQ identity: Worker kind: WorkPacketKind. self createWorker: Worker priority: 1000 work: workQ state: RichTaskState waitingWithPacket. workQ := self createPacket: nil identity: DeviceA kind: DevicePacketKind. workQ := self createPacket: workQ identity: DeviceA kind: DevicePacketKind. workQ := self createPacket: workQ identity: DeviceA kind: DevicePacketKind. self createHandler: HandlerA priority: 2000 work: workQ state: RichTaskState waitingWithPacket. workQ := self createPacket: nil identity: DeviceB kind: DevicePacketKind. workQ := self createPacket: workQ identity: DeviceB kind: DevicePacketKind. workQ := self createPacket: workQ identity: DeviceB kind: DevicePacketKind. self createHandler: HandlerB priority: 3000 work: workQ state: RichTaskState waitingWithPacket. self createDevice: DeviceA priority: 4000 work: nil state: RichTaskState waiting. self createDevice: DeviceB priority: 5000 work: nil state: RichTaskState waiting. self schedule. queuePacketCount = 23246 & (holdCount = 9297) ifFalse: [self error: 'wrong result']. ! ----- Method: RichRunner>>wait (in category 'private') ----- wait currentTask taskWaiting: true. ^ currentTask! RichObject subclass: #RichTaskState instanceVariableNames: 'packetPendingIV taskHolding taskWaiting' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Richards'! !RichTaskState commentStamp: '<historical>' prior: 0! Abstract task that manipulates work packets.! RichTaskState subclass: #RichTaskControlBlock instanceVariableNames: 'link identity priority input state function handle' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Richards'! !RichTaskControlBlock commentStamp: '<historical>' prior: 0! A task control block manages a task and the queue of work packages associated with it.! ----- Method: RichTaskControlBlock class>>link:create:priority:initialWorkQueue:initialState:function:privateData: (in category 'instance creation') ----- link: link create: identity priority: priority initialWorkQueue: initialWorkQueue initialState: initialState function: aBlock privateData: privateData ^ self new link: link identity: identity priority: priority initialWorkQueue: initialWorkQueue initialState: initialState function: aBlock privateData: privateData! ----- Method: RichTaskControlBlock>>addInput:checkPriority: (in category 'scheduling') ----- addInput: packet checkPriority: oldTask input ifNil: [input := packet. packetPendingIV := true. priority > oldTask priority ifTrue: [ ^ self ]] ifNotNil: [ input := self append: packet head: input ]. ^ oldTask! ----- Method: RichTaskControlBlock>>identity (in category 'accessing') ----- identity ^ identity! ----- Method: RichTaskControlBlock>>link (in category 'accessing') ----- link ^ link! ----- Method: RichTaskControlBlock>>link:identity:priority:initialWorkQueue:initialState:function:privateData: (in category 'initialize') ----- link: aLink identity: anIdentity priority: aPriority initialWorkQueue: anInitialWorkQueue initialState: anInitialState function: aBlock privateData: aPrivateData link := aLink. identity := anIdentity. priority := aPriority. input := anInitialWorkQueue. packetPendingIV := anInitialState isPacketPending. taskWaiting := anInitialState isTaskWaiting. taskHolding := anInitialState isTaskHolding. function := aBlock. handle := aPrivateData! ----- Method: RichTaskControlBlock>>priority (in category 'accessing') ----- priority ^ priority! ----- Method: RichTaskControlBlock>>runTask (in category 'scheduling') ----- runTask | message | self isWaitingWithPacket ifTrue: [message := input. input := message link. input ifNil: [self running] ifNotNil: [self packetPending]] ifFalse: [message := nil]. ^ function value: message value: handle! ----- Method: RichTaskState class>>packetPending (in category 'instance creation') ----- packetPending ^super new packetPending! ----- Method: RichTaskState class>>running (in category 'instance creation') ----- running ^super new running! ----- Method: RichTaskState class>>waiting (in category 'instance creation') ----- waiting ^super new waiting! ----- Method: RichTaskState class>>waitingWithPacket (in category 'instance creation') ----- waitingWithPacket ^super new waitingWithPacket! ----- Method: RichTaskState>>isPacketPending (in category 'testing') ----- isPacketPending ^packetPendingIV! ----- Method: RichTaskState>>isRunning (in category 'testing') ----- isRunning ^packetPendingIV not and: [taskWaiting not and: [taskHolding not]]! ----- Method: RichTaskState>>isTaskHolding (in category 'testing') ----- isTaskHolding ^taskHolding! ----- Method: RichTaskState>>isTaskHoldingOrWaiting (in category 'testing') ----- isTaskHoldingOrWaiting ^taskHolding or: [packetPendingIV not and: [taskWaiting]]! ----- Method: RichTaskState>>isTaskWaiting (in category 'testing') ----- isTaskWaiting ^taskWaiting! ----- Method: RichTaskState>>isWaiting (in category 'testing') ----- isWaiting ^packetPendingIV not and: [taskWaiting and: [taskHolding not]]! ----- Method: RichTaskState>>isWaitingWithPacket (in category 'testing') ----- isWaitingWithPacket ^packetPendingIV and: [taskWaiting and: [taskHolding not]]! ----- Method: RichTaskState>>packetPending (in category 'initialize') ----- packetPending packetPendingIV := true. taskWaiting := false. taskHolding := false! ----- Method: RichTaskState>>running (in category 'initialize') ----- running packetPendingIV := taskWaiting := taskHolding := false! ----- Method: RichTaskState>>taskHolding: (in category 'accessing') ----- taskHolding: anObject ^ taskHolding := anObject! ----- Method: RichTaskState>>taskWaiting: (in category 'accessing') ----- taskWaiting: anObject ^ taskWaiting := anObject! ----- Method: RichTaskState>>waiting (in category 'initialize') ----- waiting packetPendingIV := taskHolding := false. taskWaiting := true! ----- Method: RichTaskState>>waitingWithPacket (in category 'initialize') ----- waitingWithPacket taskHolding := false. taskWaiting := packetPendingIV := true! RichObject subclass: #RichWorkerTaskDataRecord instanceVariableNames: 'destination count' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Richards'! !RichWorkerTaskDataRecord commentStamp: '<historical>' prior: 0! A task that manipulates work packets.! ----- Method: RichWorkerTaskDataRecord>>count (in category 'accessing') ----- count ^ count! ----- Method: RichWorkerTaskDataRecord>>count: (in category 'accessing') ----- count: anObject count := anObject! ----- Method: RichWorkerTaskDataRecord>>destination (in category 'accessing') ----- destination ^ destination! ----- Method: RichWorkerTaskDataRecord>>destination: (in category 'accessing') ----- destination: anObject destination := anObject! ----- Method: RichWorkerTaskDataRecord>>initialize (in category 'as yet unclassified') ----- initialize destination := HandlerA. count := 0 ! Object subclass: #SMarkHarness instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! !SMarkHarness commentStamp: '<historical>' prior: 0! A benchmark harness steers the execution and reporting of benchmarks. For that purpose, it will use a designated benchmark runner to do the execution and a benchmark reporter to output the results. The benchmark harness is also parameterized by the benchmark suites that are to be executed. The simplest way to execute a benchmark suite is to use SMarkSuite >> #run. However, directly using the harness classes gives more freedom on reporting and execution strategies. A typical call of the harness from the commandline would result in the following invokation: SMarkHarness run: {'SMarkHarness'. 'SMarkLoops.benchIntLoop'. 1. 1. 5}! SMarkHarness subclass: #ReBenchHarness instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! !ReBenchHarness commentStamp: 'StefanMarr 5/16/2011 09:10' prior: 0! The ReBenchHarness is optimized for use from the command-line. It is especially meant to be used together with ReBench, a tool to execute and document benchmarks reproducibly. See: https://github.com/smarr/ReBench#readme! ----- Method: ReBenchHarness class>>defaultArgumentParser (in category 'helper') ----- defaultArgumentParser ^ ReBenchHarnessArgumentParser! ----- Method: ReBenchHarness class>>defaultReporter (in category 'defaults') ----- defaultReporter ^ ReBenchReporter! ----- Method: ReBenchHarness class>>defaultRunner (in category 'defaults') ----- defaultRunner ^ SMarkWeakScalingRunner! ----- Method: ReBenchHarness class>>usageBenchmarkParameters: (in category 'helper') ----- usageBenchmarkParameters: usage ^ usage, ' processes optional, number of processes/threads used by the benchmarks', String crlf, ' inner-iterations optional, number of iterations done by a single process', String crlf, ' problemSize optional, depending on benchmark for instance size of used data set', String crlf. ! ----- Method: ReBenchHarness class>>usageHeader (in category 'helper') ----- usageHeader | usage | usage := 'SMark Benchmark Framework, version: ', self version, String crlf. usage := usage, String crlf. usage := usage, 'Usage: <vm+image> ', self name, ' <suiteOrBenchmark> [processes [inner-iterations [problemSize]]]', String crlf. usage := usage, String crlf. usage := usage, ' This harness is used for weak-scalling benchmarks.', String crlf. usage := usage, ' Use the SMarkHarness for more general settings, it offers more options.', String crlf. usage := usage, String crlf. ^ usage! ----- Method: ReBenchHarness class>>usageReporter: (in category 'helper') ----- usageReporter: usage "Will rely on default, which is good for ReBench, so do not advertise option." ^ usage! ----- Method: ReBenchHarness class>>usageRunner: (in category 'helper') ----- usageRunner: usage "Will rely on default, which is good for ReBench, so do not advertise option." ^ usage! ----- Method: SMarkHarness class>>defaultArgumentParser (in category 'helper') ----- defaultArgumentParser ^ SMarkHarnessArgumentParser! ----- Method: SMarkHarness class>>defaultOutputDestination (in category 'defaults') ----- defaultOutputDestination ^ Smalltalk at: #ScriptConsole ifAbsent: [SMarkReporter defaultOutputDestination]! ----- Method: SMarkHarness class>>defaultReporter (in category 'defaults') ----- defaultReporter ^ SMarkReporter defaultReporter! ----- Method: SMarkHarness class>>defaultRunner (in category 'defaults') ----- defaultRunner ^ SMarkSuite defaultRunner! ----- Method: SMarkHarness class>>execute:andReport: (in category 'benchmarking') ----- execute: runner andReport: reporter runner reportConfiguration: self defaultOutputDestination. runner execute. reporter runner: runner. reporter outputStream: self defaultOutputDestination. reporter report.! ----- Method: SMarkHarness class>>execute:using:andReport: (in category 'benchmarking') ----- execute: aBenchmarkOrSuite using: aRunnerClass andReport: withAReporterClass | parsedBenchmarkOrSuite runner reporter | parsedBenchmarkOrSuite := self parseBenchmarkOrSuite: aBenchmarkOrSuite. runner := aRunnerClass new. reporter := withAReporterClass new. self instructRunner: runner with: parsedBenchmarkOrSuite. self execute: runner andReport: reporter. ! ----- Method: SMarkHarness class>>parseArguments: (in category 'helper') ----- parseArguments: arguments | parser | parser := self defaultArgumentParser new. parser harness: self. ^ parser parse: arguments.! ----- Method: SMarkHarness class>>run: (in category 'script entry') ----- run: arguments "Executed from the command line using something similar to ./vm my.image SMarkHarness SMarkRunner SMarkReporter SMarkLoops\>\>benchIntLoop 1 1 5 ./vm my.image SMarkHarness SMarkRunner SMarkReporter SMarkLoops.benchIntLoop 1 1 5" | runner reporter runnerAndReporter | (self shouldShowUsage: arguments) ifTrue: [ self usage. ^ self. ]. runnerAndReporter := self parseArguments: arguments. runner := runnerAndReporter first. reporter := runnerAndReporter second. self execute: runner andReport: reporter. ! ----- Method: SMarkHarness class>>shouldShowUsage: (in category 'helper') ----- shouldShowUsage: arguments arguments size < 2 ifTrue: [^ true ]. ^ arguments anySatisfy: [:elem | (elem = '--help') or: [elem = '-?'] ]. ! ----- Method: SMarkHarness class>>usage (in category 'helper') ----- usage | usage | "Example usage: SMarkHarness SMarkRunner SMarkReporter SMarkLoops.benchIntLoop 1 1 5" usage := self usageHeader. usage := usage, 'Arguments:', String crlf. usage := self usageRunner: usage. usage := self usageReporter: usage. usage := usage, ' suiteOrBenchmark required, either a SMarkSuite with benchmarks,', String crlf. usage := usage, ' or a benchmark denoted by Suite.benchName', String crlf. usage := self usageBenchmarkParameters: usage. self defaultOutputDestination print: usage.! ----- Method: SMarkHarness class>>usageBenchmarkParameters: (in category 'helper') ----- usageBenchmarkParameters: usage ^ usage, ' iterations optional, number of times the benchmarks are repeated', String crlf, ' processes optional, number of processes/threads used by the benchmarks', String crlf, ' problemSize optional, depending on benchmark for instance number of', String crlf, ' inner iterations or size of used data set', String crlf. ! ----- Method: SMarkHarness class>>usageHeader (in category 'helper') ----- usageHeader | usage | usage := 'SMark Benchmark Framework, version: ', self version, String crlf. usage := usage, String crlf. usage := usage, 'Usage: <vm+image> ', self name, ' [runner] [reporter] <suiteOrBenchmark>', String crlf. usage := usage, ' [iterations [processes [problemSize]]]', String crlf. usage := usage, String crlf. ^ usage! ----- Method: SMarkHarness class>>usageReporter: (in category 'helper') ----- usageReporter: usage ^ usage, ' reporter optional, a SMarkReporter class that processes', String crlf, ' and displays the results', String crlf. ! ----- Method: SMarkHarness class>>usageRunner: (in category 'helper') ----- usageRunner: usage ^ usage, ' runner optional, a SMarkRunner class that executes the benchmarks', String crlf.! ----- Method: SMarkHarness class>>version (in category 'helper') ----- version (Smalltalk classNamed: #ConfigurationOfBenchmarking) ifNotNilDo: [:cfg | ^ cfg project currentVersion versionNumber asString. ]. (Smalltalk classNamed: #MCPackage) ifNotNilDo: [:mcp | | package | package := mcp named: 'SMark'. package hasWorkingCopy ifTrue: [ ^ package workingCopy ancestors first name. ]. ]. ^ ''.! Object subclass: #SMarkHarnessArgumentParser instanceVariableNames: 'runner reporter suiteOrBenchmark iterations processes problemSize i current numParams currentObj arguments suite specificBenchmark suiteClass harness' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! SMarkHarnessArgumentParser subclass: #ReBenchHarnessArgumentParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! ----- Method: ReBenchHarnessArgumentParser>>determineBenchmarkParametersFromArguments (in category 'argument parsing') ----- determineBenchmarkParametersFromArguments i := i + 1. i <= numParams ifTrue: [ processes := (arguments at: i) asInteger. i := i + 1. i <= numParams ifTrue: [ iterations := (arguments at: i) asInteger. i := i + 1. i <= numParams ifTrue: [ problemSize := arguments at: i. ] ] ].! ----- Method: ReBenchHarnessArgumentParser>>determineReporter (in category 'argument parsing') ----- determineReporter reporter := harness defaultReporter new.! ----- Method: ReBenchHarnessArgumentParser>>determineRunner (in category 'argument parsing') ----- determineRunner runner := harness defaultRunner new.! ----- Method: ReBenchHarnessArgumentParser>>instructRunner (in category 'helper') ----- instructRunner super instructRunner. runner iterations: runner class defaultNumberOfIterations. runner innerIterations: iterations.! ----- Method: SMarkHarnessArgumentParser>>determineBenchmarkParameters (in category 'argument parsing') ----- determineBenchmarkParameters "Initialize with defaults, will be overwritten in case it is specified." iterations := runner class defaultNumberOfIterations. processes := runner class defaultNumberOfProcesses. problemSize:= suiteClass defaultProblemSize. self determineBenchmarkParametersFromArguments.! ----- Method: SMarkHarnessArgumentParser>>determineBenchmarkParametersFromArguments (in category 'argument parsing') ----- determineBenchmarkParametersFromArguments i := i + 1. i <= numParams ifTrue: [ iterations := (arguments at: i) asInteger. i := i + 1. i <= numParams ifTrue: [ processes := (arguments at: i) asInteger. i := i + 1. i <= numParams ifTrue: [ problemSize := arguments at: i. ] ] ].! ----- Method: SMarkHarnessArgumentParser>>determineReporter (in category 'argument parsing') ----- determineReporter (currentObj isKindOf: SMarkReporter) ifFalse: [ reporter := harness defaultReporter new. ] ifTrue: [ reporter := currentObj. i := i + 1. i <= numParams ifTrue: [ current := arguments at: i. ] ].! ----- Method: SMarkHarnessArgumentParser>>determineRunner (in category 'argument parsing') ----- determineRunner (currentObj isKindOf: SMarkRunner) ifFalse: [ runner := harness defaultRunner new. ] ifTrue: [ runner := currentObj. i := i + 1. i <= numParams ifTrue: [ current := arguments at: i. currentObj := (Smalltalk classNamed: current) ifNotNilDo: [:cls | cls new]. ] ].! ----- Method: SMarkHarnessArgumentParser>>determineSuiteOrBenchmark (in category 'argument parsing') ----- determineSuiteOrBenchmark self parseBenchmarkOrSuite: current.! ----- Method: SMarkHarnessArgumentParser>>harness: (in category 'accessing') ----- harness: aHarness harness := aHarness! ----- Method: SMarkHarnessArgumentParser>>instructRunner (in category 'helper') ----- instructRunner suite := suiteClass new. specificBenchmark ifNotNil: [ suite runOnly: specificBenchmark. ]. runner suite: suite. runner iterations: iterations. runner processes: processes. runner problemSize: problemSize.! ----- Method: SMarkHarnessArgumentParser>>parse: (in category 'parsing') ----- parse: argumentsArray arguments := argumentsArray. numParams := arguments size. i := 2. current := arguments at: i. currentObj := (Smalltalk classNamed: current) ifNotNilDo: [:cls | cls new]. self determineRunner. self determineReporter. self determineSuiteOrBenchmark. self determineBenchmarkParameters. self instructRunner. ^ {runner. reporter}! ----- Method: SMarkHarnessArgumentParser>>parseBenchmarkOrSuite: (in category 'argument parsing') ----- parseBenchmarkOrSuite: aBenchmarkOrSuite "Identify the benchmark suite or suite and benchmark method that should be executed. The string should be of the format 'Class>>benchName' or 'Class.benchName' for shell/bash compatibility. Accepts a string, class, or array. Returns, a class, or an array of a class and a symbol." | parsed | (aBenchmarkOrSuite isKindOf: Class) ifTrue: [ suiteClass := aBenchmarkOrSuite. ^ suiteClass ]. (aBenchmarkOrSuite isKindOf: Array) ifTrue: [ parsed := aBenchmarkOrSuite. ] ifFalse: [ parsed := aBenchmarkOrSuite findTokens: '>.'. ]. ((parsed size > 2) or: [parsed size < 1]) ifTrue: [ Error signal: 'The passed argument has to represent two elements. A class/classname and a method symbol' ]. suiteClass := parsed first. (suiteClass isKindOf: Class) ifFalse: [ suiteClass := Smalltalk at: (suiteClass asSymbol) ifAbsent: [Error signal: 'Class that was supposed to represent a benchmark suite was not found: ', suiteClass asString ]]. parsed size = 1 ifTrue: [^suiteClass]. specificBenchmark := parsed second asSymbol. ^ { suiteClass. specificBenchmark } ! Object subclass: #SMarkReporter instanceVariableNames: 'runner stream' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! !SMarkReporter commentStamp: '<historical>' prior: 0! SMarkReporter is a simple formatter of benchmark results. Subclass such as SMarkSimpleStatisticsReporter might implement more advanced reporting functionality, e.g., including a statistical evaluation of the results. Example: | f | f := TextStream on: String new. SMarkSimpleStatisticsReporter reportFor: (SMarkTestRunnerSuiteForAutosizing run: 10) on: f. f contents! ----- Method: SMarkReporter class>>defaultOutputDestination (in category 'defaults') ----- defaultOutputDestination ^ ScriptConsole! ----- Method: SMarkReporter class>>defaultReporter (in category 'defaults') ----- defaultReporter ^ SMarkSimpleStatisticsReporter! ----- Method: SMarkReporter class>>reportFor: (in category 'reporting') ----- reportFor: aRunner self reportFor: aRunner on: self defaultOutputDestination.! ----- Method: SMarkReporter class>>reportFor:on: (in category 'reporting') ----- reportFor: aRunner on: aStream | reporter | reporter := self new. reporter runner: aRunner. reporter outputStream: aStream. reporter report. ^ reporter.! ----- Method: SMarkReporter>>benchmarkFooter: (in category 'reporting') ----- benchmarkFooter: aName stream cr.! ----- Method: SMarkReporter>>benchmarkHeader: (in category 'reporting') ----- benchmarkHeader: aName stream << 'Benchmark ' << (aName asString); cr.! ----- Method: SMarkReporter>>footer (in category 'reporting') ----- footer "No output at the moment" ^ self! ----- Method: SMarkReporter>>header (in category 'reporting') ----- header | suiteName | suiteName := runner suite class name asString. stream << 'Report for: ' << suiteName; cr.! ----- Method: SMarkReporter>>initialize (in category 'initialization') ----- initialize super initialize. stream := self class defaultOutputDestination.! ----- Method: SMarkReporter>>outputStream: (in category 'accessing') ----- outputStream: aStream stream := aStream ! ----- Method: SMarkReporter>>report (in category 'accessing') ----- report self header. runner results keysAndValuesDo: [:key :value | self benchmarkHeader: key. self reportAllRuns: value of: key. self benchmarkFooter: key. ]. self footer. ^ self! ----- Method: SMarkReporter>>reportAllRuns:of: (in category 'reporting') ----- reportAllRuns: aListOfResults of: benchmark aListOfResults do: [:result | result criteria keysAndValuesDo: [:benchName :timer | stream << benchName << ': ' << (timer totalTime asString, 'ms'); cr.]]! ----- Method: SMarkReporter>>runner: (in category 'accessing') ----- runner: aRunner runner := aRunner.! SMarkReporter subclass: #SMarkSimpleStatisticsReporter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! SMarkSimpleStatisticsReporter subclass: #ReBenchReporter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! !ReBenchReporter commentStamp: '<historical>' prior: 0! A ReBenchReporter is reporter for the ReBench framework (cf. https://github.com/smarr/ReBench). It is used be the ReBenchHarness, which is the main class of interest for users that just want to execute benchmarks.! ----- Method: ReBenchReporter>>benchmarkHeader: (in category 'as yet unclassified') ----- benchmarkHeader: aName ^ self! ----- Method: SMarkSimpleStatisticsReporter>>confidenceVariance: (in category 'statistics') ----- confidenceVariance: times | numMeasurements | numMeasurements := times size. (numMeasurements >= 30) ifTrue: [ ^ (self gaussianConfidenceFactor) * (times stdev) / (numMeasurements asFloat sqrt)]. "use the students T distribution for small probe counts" ^ (self studentsTConfidenceFactorFor: numMeasurements) * (times stdev) / (numMeasurements asFloat sqrt)! ----- Method: SMarkSimpleStatisticsReporter>>gaussianConfidenceFactor (in category 'statistics') ----- gaussianConfidenceFactor "used for large probe counts >= 30" "1 ~ 68.27%" "1.644853626951 ~ 90%" "2 ~ 95.45%" ^ 1.644853626951! ----- Method: SMarkSimpleStatisticsReporter>>reportAllRuns:of: (in category 'reporting') ----- reportAllRuns: aListOfResults of: benchmark | criteria | criteria := aListOfResults first criteria. criteria keysDo: [:criterion | | times | times := self resultsFor: criterion from: aListOfResults. self reportResult: times for: criterion of: benchmark. stream cr. ].! ----- Method: SMarkSimpleStatisticsReporter>>reportResult:for:of: (in category 'reporting') ----- reportResult: aResultsArray for: aCriterion of: benchmark | convidenceVariance significantDigits | stream << benchmark << ' ' << aCriterion << ': iterations='. aResultsArray size printOn: stream . stream << ' runtime: '. aResultsArray size < 2 ifTrue: [ aResultsArray average printOn: stream. stream << 'ms'. ^ self. ]. convidenceVariance := self confidenceVariance: aResultsArray. "only print significant " significantDigits := self significantDigits: convidenceVariance. aResultsArray average printOn: stream showingDecimalPlaces: significantDigits. stream << 'ms +/-'. convidenceVariance printOn: stream showingDecimalPlaces: significantDigits.! ----- Method: SMarkSimpleStatisticsReporter>>resultsFor:from: (in category 'helper') ----- resultsFor: aCriterion from: aListOfResults ^aListOfResults collect: [:result | (result criteria at: aCriterion) totalTime] ! ----- Method: SMarkSimpleStatisticsReporter>>significantDigits: (in category 'statistics') ----- significantDigits: confidenceVariance confidenceVariance = 0 ifTrue: [ ^ 2]. confidenceVariance >= 10 ifTrue: [ ^ 0]. ^ 1 - (confidenceVariance log floor)! ----- Method: SMarkSimpleStatisticsReporter>>studentsTConfidenceFactorFor: (in category 'statistics') ----- studentsTConfidenceFactorFor: aNumberOfMeasurements "used for small probe counts < 30" "the students T distribution sucks to calculate since the value depends on the probeCout" "these values are for a confidence interval of ~90%" | values | values := Array new: 30. values at: 1 put: 6.314. values at: 2 put: 2.920. values at: 3 put: 2.353. values at: 4 put: 2.132. values at: 5 put: 2.015. values at: 6 put: 1.943. values at: 7 put: 1.895. values at: 8 put: 1.860. values at: 9 put: 1.833. values at: 10 put: 1.812. values at: 11 put: 1.796. values at: 12 put: 1.782. values at: 13 put: 1.771. values at: 14 put: 1.761. values at: 15 put: 1.753. values at: 16 put: 1.746. values at: 17 put: 1.740. values at: 18 put: 1.734. values at: 19 put: 1.729. values at: 20 put: 1.725. values at: 21 put: 1.721. values at: 22 put: 1.717. values at: 23 put: 1.714. values at: 24 put: 1.711. values at: 25 put: 1.708. values at: 26 put: 1.706. values at: 27 put: 1.703. values at: 28 put: 1.701. values at: 29 put: 1.699. values at: 30 put: 1.697. ^ values at: aNumberOfMeasurements. ! ----- Method: SMarkSimpleStatisticsReporter>>totalResultsFor: (in category 'helper') ----- totalResultsFor: aListOfResults ^aListOfResults collect: [:timer | timer total] ! Object subclass: #SMarkResult instanceVariableNames: 'time benchName suite criteria' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! !SMarkResult commentStamp: 'StefanMarr 3/18/2011 23:45' prior: 0! A benchmark result is characterized by: - the total execution time (#total is the least a benchmark results in) - the name of the benchmark that was executed - the suite object specifies the used input used for the benchmark - dictionary of additional the criteria and the related timings A benchmark can produced multiple resuts for different criteria. The standard criterion is #total.! ----- Method: SMarkResult>>benchmarkName (in category 'accessing') ----- benchmarkName ^ benchName! ----- Method: SMarkResult>>benchmarkName: (in category 'accessing') ----- benchmarkName: aString benchName := aString! ----- Method: SMarkResult>>criteria (in category 'accessing') ----- criteria ^ criteria! ----- Method: SMarkResult>>criteria: (in category 'accessing') ----- criteria: aCollectionOfTimers criteria := aCollectionOfTimers! ----- Method: SMarkResult>>suite (in category 'accessing') ----- suite ^ suite! ----- Method: SMarkResult>>suite: (in category 'accessing') ----- suite: aBenchmarkSuite suite := aBenchmarkSuite! ----- Method: SMarkResult>>total (in category 'accessing') ----- total ^ time! ----- Method: SMarkResult>>total: (in category 'accessing') ----- total: aTime time := aTime! Object subclass: #SMarkRunner instanceVariableNames: 'numIterations suite runner results currentBenchmark timers problemSize numProcesses' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! SMarkRunner subclass: #SMarkAutosizeRunner instanceVariableNames: 'targetTime innerLoopIterations' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! ----- Method: SMarkAutosizeRunner class>>defaultTargetTime (in category 'defaults') ----- defaultTargetTime "300 milliseconds seems to be a reasonable target time for most problems. It is a compromise between the general measurment noise as well as timer accuracy and the absolute runtime of benchmarks" ^ 300! ----- Method: SMarkAutosizeRunner>>initialize (in category 'initialization') ----- initialize super initialize. targetTime := self class defaultTargetTime.! ----- Method: SMarkAutosizeRunner>>performBenchmark: (in category 'benchmarking') ----- performBenchmark: aSelector "First determine a useful number of inner loop iterations until the targetTime is reached." | execTime i | "make sure no timers are recorded for this" timers := nil. i := 1. execTime := Time millisecondsToRun: [ suite perform: aSelector. ]. [ execTime > targetTime ] whileFalse: [ i := i * 2. "Was thinking of doing something fancy here, but just go with this simple staight-forward solution" execTime := Time millisecondsToRun: [ 1 to: i do: [:ignored| suite perform: aSelector]]. ]. innerLoopIterations := i. "Then start executing the benchmark" ^ super performBenchmark: aSelector.! ----- Method: SMarkAutosizeRunner>>runBaseBenchmark (in category 'benchmarking') ----- runBaseBenchmark "baseBenchmark is not supported with autosizing. I do not see how that can be made possible since all different benchmarks will have different number of iterations, and the only way how a consistent baseline could be found would be to normalize the results, but well, incooprorating the baseline measurement with the statistical evaluation is harder than just substracting a one time value..., I am not going to do that here for the moment. Stefan 2011-03-20" (suite respondsTo: #baseBenchmark) ifFalse: [ ^ nil ]. "I decided to go here with a silent solution to avoid thinking about logging frameworks and Transcript to console convertion..." self recordResults: (self class defaultTimer new: 'total') for: #baseBenchmark ! ----- Method: SMarkAutosizeRunner>>targetTime (in category 'accessing') ----- targetTime "Target time in milliseconds" ^ targetTime! ----- Method: SMarkAutosizeRunner>>targetTime: (in category 'accessing') ----- targetTime: anIntInMilliseconds "Target time in milliseconds" targetTime := anIntInMilliseconds! ----- Method: SMarkAutosizeRunner>>timedBenchmarkExecution: (in category 'benchmarking') ----- timedBenchmarkExecution: aSelector "Will do a timed execution of the benchmark and return the result timer" | timer | timers := Dictionary new. timer := self createTimer: 'total'. timer start. 1 to: innerLoopIterations do: [:ignored| suite perform: aSelector. ]. timer stop. self recordResults: timer for: aSelector. ^ timer! SMarkRunner subclass: #SMarkCogRunner instanceVariableNames: 'warmingUp' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! !SMarkCogRunner commentStamp: 'StefanMarr 12/30/2011 23:24' prior: 0! This runner is doing warmup on for Cog VMs with just-in-time compilation. The goal is to bring the JIT compiler into a steady state where no jitting is performed anymore during benchmarking.! ----- Method: SMarkCogRunner>>initialize (in category 'initialization') ----- initialize super initialize. warmingUp := false.! ----- Method: SMarkCogRunner>>performBenchmark: (in category 'initialization') ----- performBenchmark: aSelector "Based on an email by Eliot from May 16th, 2011. The first time a method is executed it will get into the inline cache. The second time, it is found in the inline cache, which triggers the JIT compiler to produce code. Thus, the third time it should be executed in the steady state." warmingUp := true. suite runBenchmark: aSelector. Smalltalk garbageCollect. suite runBenchmark: aSelector. Smalltalk garbageCollect. warmingUp := false. ^ super performBenchmark: aSelector.! ----- Method: SMarkCogRunner>>recordResults:for: (in category 'initialization') ----- recordResults: timer for: aSelector "Only record the results when we are not in warmup mode." warmingUp ifFalse: [ super recordResults: timer for: aSelector. ].! SMarkRunner subclass: #SMarkProfileRunner instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! !SMarkProfileRunner commentStamp: '<historical>' prior: 0! This runner profiles the benchmarks for better analysis. Unlike the classical benchmark runner this one will not collect the results. Instead it will execute the benchmarks in the system profiler.! ----- Method: SMarkProfileRunner class>>execute:selector: (in category 'profiling') ----- execute: aSuite selector: aBenchmarkSelector | runner | runner := self new. aSuite runner: runner. runner suite: aSuite; execute: aBenchmarkSelector. ^ runner! ----- Method: SMarkProfileRunner class>>execute:selector:iterations: (in category 'profiling') ----- execute: aSuite selector: aBenchmarkSelector iterations: nIterations | runner | runner := self new. aSuite runner: runner. runner suite: aSuite; iterations: nIterations; execute: aBenchmarkSelector. ^ runner! ----- Method: SMarkProfileRunner>>execute (in category 'profiling') ----- execute "run all benchmnarks in a benchmark suite " [ suite run ] timeProfile! ----- Method: SMarkProfileRunner>>execute: (in category 'profiling') ----- execute: aSelector [ self performBenchmark: aSelector ] timeProfile! ----- Method: SMarkProfileRunner>>initialize (in category 'initialization') ----- initialize super initialize. numIterations := 1.! ----- Method: SMarkProfileRunner>>performBenchmark: (in category 'benchmarks') ----- performBenchmark: aSelector currentBenchmark := aSelector. 1 to: numIterations do: [:i| suite runBenchmark: aSelector ]. currentBenchmark := nil.! ----- Method: SMarkProfileRunner>>timedBenchmarkExecution: (in category 'benchmarks') ----- timedBenchmarkExecution: aSelector suite perform: aSelector! ----- Method: SMarkRunner class>>defaultNumberOfIterations (in category 'defaults') ----- defaultNumberOfIterations ^ 1! ----- Method: SMarkRunner class>>defaultNumberOfProcesses (in category 'defaults') ----- defaultNumberOfProcesses ^ 1! ----- Method: SMarkRunner class>>defaultTimer (in category 'defaults') ----- defaultTimer ^ SMarkTimer! ----- Method: SMarkRunner class>>execute: (in category 'benchmarking') ----- execute: aSuite ^ self execute: aSuite with: 1.! ----- Method: SMarkRunner class>>execute:with: (in category 'benchmarking') ----- execute: aSuite with: nIterations | runner | runner := self new. aSuite runner: runner. runner suite: aSuite. runner iterations: nIterations. runner execute. ^ runner! ----- Method: SMarkRunner>>createTimer: (in category 'helper') ----- createTimer: name "Create and register a new timer for the current benchmark" | timer | timer := self class defaultTimer new: name. timers ifNotNil: [ timers at: name put: timer. ]. ^ timer.! ----- Method: SMarkRunner>>execute (in category 'execution') ----- execute suite run. self runBaseBenchmark. ^ results ! ----- Method: SMarkRunner>>initialize (in category 'initialization') ----- initialize super initialize. numIterations := self class defaultNumberOfIterations. numProcesses := self class defaultNumberOfProcesses. results := Dictionary new.! ----- Method: SMarkRunner>>iterations (in category 'accessing') ----- iterations ^ numIterations! ----- Method: SMarkRunner>>iterations: (in category 'accessing') ----- iterations: anInteger numIterations := anInteger! ----- Method: SMarkRunner>>performBenchmark: (in category 'benchmarking') ----- performBenchmark: aSelector currentBenchmark := aSelector. 1 to: numIterations do: [:i| "self timedBenchmarkExecution: aSelector." suite runBenchmark: aSelector. ]. currentBenchmark := nil. ^ results at: (suite benchmarkNameForSelector: aSelector)! ----- Method: SMarkRunner>>printOn: (in category 'printing') ----- printOn: aStream ^ self reportOn: aStream.! ----- Method: SMarkRunner>>problemSize (in category 'accessing') ----- problemSize <omniUnenforced> "Hint for the OMOP that it is part of the meta infrastructure" ^ problemSize! ----- Method: SMarkRunner>>problemSize: (in category 'accessing') ----- problemSize: aValue "Do some conversion to make it easier for the benchmarks" (aValue isString and: [aValue isAllDigits]) ifTrue: [ problemSize := Number readFrom: aValue. ^ self. ]. problemSize := aValue! ----- Method: SMarkRunner>>processes (in category 'accessing') ----- processes "The standard runner does use only a single process, but in case a benchmark supports parallelism it can query for the intended degree of parallelism" ^ numProcesses! ----- Method: SMarkRunner>>processes: (in category 'accessing') ----- processes: anInt "The standard runner does use only a single process, but a benchmark can use that to do its own parallelism" numProcesses := anInt! ----- Method: SMarkRunner>>recordResults:for: (in category 'helper') ----- recordResults: timer for: aSelector | result name | name := suite benchmarkNameForSelector: aSelector. result := SMarkResult new. result total: timer totalTime. result benchmarkName: name. result suite: suite. result criteria: timers. (results at: name ifAbsentPut: OrderedCollection new) add: result.! ----- Method: SMarkRunner>>report (in category 'accessing') ----- report SMarkReporter defaultReporter reportFor: self. ! ----- Method: SMarkRunner>>reportConfiguration: (in category 'reporting') ----- reportConfiguration: aStream aStream << 'Runner Configuration:';cr. aStream << (' iterations: ', numIterations asString); cr. aStream << (' processes: ', numProcesses asString); cr. aStream << (' problem size: ', problemSize asString); cr. ! ----- Method: SMarkRunner>>reportOn: (in category 'reporting') ----- reportOn: aStream SMarkReporter defaultReporter reportFor: self on: aStream ! ----- Method: SMarkRunner>>results (in category 'accessing') ----- results ^ results! ----- Method: SMarkRunner>>runBaseBenchmark (in category 'benchmarking') ----- runBaseBenchmark "In certain sitatuations it is one wants a baseline that is incooprated in all benchmark results to be substracted from the final values. #baseBenchmark can be used to charaterize such a baseline" (suite respondsTo: #baseBenchmark) ifFalse: [ ^ nil ]. ^ self performBenchmark: #baseBenchmark.! ----- Method: SMarkRunner>>suite (in category 'accessing') ----- suite ^ suite! ----- Method: SMarkRunner>>suite: (in category 'accessing') ----- suite: aBenchmarkSuite suite := aBenchmarkSuite. suite runner: self.! ----- Method: SMarkRunner>>timedBenchmarkExecution: (in category 'benchmarking') ----- timedBenchmarkExecution: aSelector "Will do a timed execution of the benchmark and return the result timer" | timer result | timers := Dictionary new. timer := self createTimer: 'total'. timer start. result := suite perform: aSelector. timer stop. suite processResult: result withTimer: timer. self recordResults: timer for: aSelector. ^ timer! SMarkRunner subclass: #SMarkWeakScalingRunner instanceVariableNames: 'numInnerIterations runningProcesses completionSignal runningProcessesMtx' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! ----- Method: SMarkWeakScalingRunner class>>defaultNumberOfInnerIterations (in category 'defaults') ----- defaultNumberOfInnerIterations "The number of iterations of the inner loop in which the benchmark is executed." ^ 1! ----- Method: SMarkWeakScalingRunner>>execute:withProcesses:withTimer: (in category 'benchmarking') ----- execute: aSelector withProcesses: numberOfProcesses withTimer: timer "This case is meant for all cases. REM: this is also used for numProc==1 to be able to measure the process start overhead in all cases. It will start the processes and wait for their completion." | processes | processes := Array new: numberOfProcesses. runningProcessesMtx := Semaphore forMutualExclusion. completionSignal := Semaphore new. runningProcesses := numberOfProcesses. "First initialize the processes" 1 to: numberOfProcesses do: [ :procNum | | proc | proc := SMarkWeakScalingRunnerExecutor createFor: aSelector for: numInnerIterations with: self and: suite. proc priority: Processor highestPriority. proc name: (self class name, '-', procNum asString). processes at: procNum put: proc. "On: procNum" ]. "Now, execute the benchmark and do the timing now" timer start. 1 to: numberOfProcesses do: [ :procNum | (processes at: procNum) resume. ]. completionSignal wait. timer stop. ! ----- Method: SMarkWeakScalingRunner>>executorCompleted (in category 'benchmarking') ----- executorCompleted runningProcessesMtx critical: [ runningProcesses := runningProcesses - 1. (runningProcesses == 0) ifTrue: [ completionSignal signal. ] ]! ----- Method: SMarkWeakScalingRunner>>initialize (in category 'initialization') ----- initialize super initialize. numProcesses := self class defaultNumberOfProcesses. numInnerIterations := self class defaultNumberOfInnerIterations. ! ----- Method: SMarkWeakScalingRunner>>innerIterations (in category 'benchmarking') ----- innerIterations "The number of inner iterations the benchmark is executed inside a processes" ^ numInnerIterations! ----- Method: SMarkWeakScalingRunner>>innerIterations: (in category 'benchmarking') ----- innerIterations: anInteger "The number of inner iterations the benchmark is executed inside a processes" numInnerIterations := anInteger! ----- Method: SMarkWeakScalingRunner>>processes (in category 'benchmarking') ----- processes ^ numProcesses! ----- Method: SMarkWeakScalingRunner>>processes: (in category 'benchmarking') ----- processes: anInteger numProcesses := anInteger! ----- Method: SMarkWeakScalingRunner>>reportConfiguration: (in category 'reporting') ----- reportConfiguration: aStream super reportConfiguration: aStream. aStream << ('inner iterations: ', numInnerIterations asString); cr.! ----- Method: SMarkWeakScalingRunner>>timedBenchmarkExecution: (in category 'benchmarking') ----- timedBenchmarkExecution: aSelector "Will do a timed execution of the benchmark and return the result timer" | timer | timers := Dictionary new. timer := self createTimer: 'total'. self execute: aSelector withProcesses: numProcesses withTimer: timer. self recordResults: timer for: aSelector. ^ timer! Object subclass: #SMarkSuite instanceVariableNames: 'runner selectedBenchmarks' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! !SMarkSuite commentStamp: '<historical>' prior: 0! A Benchmark Suite is a set of benchmarks and it knows what exactly needs to be executed. However, it does not really know how to execute it. It knows all the magic, that is, how to set up and tear down the environment for the benchmarks, but does not have the knowledge of how many iterations need to be done and how to evaluate any results that might be produced. Please see also SMarkHarness, which is the main class relevant for users to execute benchmarks with SMark. Usage: Choose a suite (i.e. one of my subclasses) and use the class-side #run or run: messages. To get an example print the result of the following expression: SMarkCompiler run: 10 SMarkLoops runOnly: #benchArrayAccess ! SMarkSuite subclass: #SMarkDeltaBlue instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-DeltaBlue'! !SMarkDeltaBlue commentStamp: '<historical>' prior: 0! One-way constraint solver Benchmark. The main focus in DeltaBlue is on polymorphism and object-oriented programming To run the benchmark, execute the expression 'SMarkDeltaBlue run: 10'.! ----- Method: SMarkDeltaBlue>>benchDeltaBlue (in category 'benchmarking') ----- benchDeltaBlue "This the combined benchmark." | n | n := self problemSize. DBStrength initialize. self doChain: n. self doProjection: n! ----- Method: SMarkDeltaBlue>>defaultProblemSize (in category 'defaults') ----- defaultProblemSize ^ 20000! ----- Method: SMarkDeltaBlue>>doChain: (in category 'benchmarking') ----- doChain: n | vars editConstraint plan planner | planner := DBPlanner new. vars := (1 to: n+1) collect: [ :i | DBVariable new]. "thread a chain of equality constraints through the variables" 1 to: n do: [ :i || v1 v2 | v1 := vars at: i. v2 := vars at: i + 1. DBEqualityConstraint var: v1 var: v2 strength: #required]. DBStayConstraint var: vars last strength: #strongDefault. editConstraint := DBEditConstraint var: (vars first) strength: #preferred. plan := planner extractPlanFromConstraints: (Array with: editConstraint). 1 to: 100 do: [ :v | vars first value: v. plan execute. vars last value ~= v ifTrue: [self error: 'Chain test failed!!!!']]. editConstraint destroyConstraint! ----- Method: SMarkDeltaBlue>>doProjection: (in category 'benchmarking') ----- doProjection: n "This test constructs a two sets of variables related to each other by a simple linear transformation (scale and offset)." | scale offset src dst planner dests | planner := DBPlanner new. dests := OrderedCollection new. scale := DBVariable value: 10. offset := DBVariable value: 1000. 1 to: n do: [ :i | src := DBVariable value: i. dst := DBVariable value: i. dests add: dst. DBStayConstraint var: src strength: #default. DBScaleConstraint var: src var: scale var: offset var: dst strength: #required]. planner changeVar: src newValue: 17. dst value ~= 1170 ifTrue: [self error: 'Projection test 1 failed!!!!']. planner changeVar: dst newValue: 1050. src value ~= 5 ifTrue: [self error: 'Projection test 2 failed!!!!']. planner changeVar: scale newValue: 5. 1 to: n - 1 do: [ :i | (dests at: i) value ~= (i*5 + 1000) ifTrue: [self error: 'Projection test 3 failed!!!!']]. planner changeVar: offset newValue: 2000. 1 to: n - 1 do: [ :i | (dests at: i) value ~= (i*5 + 2000) ifTrue: [self error: 'Projection test 4 failed!!!!']].! ----- Method: SMarkDeltaBlue>>problemSize (in category 'accessing') ----- problemSize <omniUnenforced> "Hint for the OMOP that it is part of the meta infrastructure" | ps | ps := super problemSize. ps isInteger ifFalse: [ ^ self defaultProblemSize]. ^ ps! SMarkSuite subclass: #SMarkRichards instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Richards'! !SMarkRichards commentStamp: '<historical>' prior: 0! Richards is an OS kernel simulation benchmark, originally written in BCPL by Martin Richards. The main focus in Richards is on property access and calling functions and methods. To run the benchmark, execute the expression 'SMarkRichards run: 10'.! ----- Method: SMarkRichards>>benchRichards (in category 'benchs') ----- benchRichards RichObject initialize. self problemSize timesRepeat: [ RichRunner start ]! ----- Method: SMarkRichards>>defaultProblemSize (in category 'benchs') ----- defaultProblemSize ^ 50! ----- Method: SMarkRichards>>problemSize (in category 'benchs') ----- problemSize <omniUnenforced> "Hint for the OMOP that it is part of the meta infrastructure" | ps | ps := super problemSize. ps isInteger ifFalse: [ ^ self defaultProblemSize]. ^ ps! ----- Method: SMarkSuite class>>defaultProblemSize (in category 'defaults') ----- defaultProblemSize ^ nil! ----- Method: SMarkSuite class>>defaultRunner (in category 'defaults') ----- defaultRunner ^ self onCog: [SMarkCogRunner] else: [SMarkRunner]! ----- Method: SMarkSuite class>>isAbstractClass (in category 'benchmarking') ----- isAbstractClass "This is a hack that is necessary in Squeak since it does not provide #isAbstractClass. Actually this class is supposed to be abstract, but well, inheritance..." ^ false! ----- Method: SMarkSuite class>>onCog:else: (in category 'platform support') ----- onCog: cogSpecificBlock else: general ^ (Smalltalk vm isRunningCogit) ifTrue: [cogSpecificBlock value] ifFalse: [general value]! ----- Method: SMarkSuite class>>profile: (in category 'profiling') ----- profile: aSelector ^ self profileRunner execute: self new selector: aSelector.! ----- Method: SMarkSuite class>>profile:iterations: (in category 'profiling') ----- profile: aSelector iterations: nIterations ^ self profileRunner execute: self new selector: aSelector iterations: nIterations.! ----- Method: SMarkSuite class>>profileAll (in category 'profiling') ----- profileAll ^ self profileRunner execute: self new.! ----- Method: SMarkSuite class>>profileRunner (in category 'profiling') ----- profileRunner ^ SMarkProfileRunner! ----- Method: SMarkSuite class>>run (in category 'benchmarking') ----- run "Execute the suite one time." ^ self defaultRunner execute: self new.! ----- Method: SMarkSuite class>>run: (in category 'benchmarking') ----- run: nIterations "Execute the suite a given number of iterations." ^ self defaultRunner execute: self new with: nIterations.! ----- Method: SMarkSuite class>>runOnly: (in category 'benchmarking') ----- runOnly: aSelector "aSelector should refer to a benchmark method. Example: SMarkLoops runOnly: #benchFloatLoop " ^ self defaultRunner execute: (self new runOnly: aSelector)! ----- Method: SMarkSuite class>>runOnly:iterations: (in category 'benchmarking') ----- runOnly: aSelector iterations: anInteger "Execute only the bench name aSelector from the suite." ^ self defaultRunner execute: (self new runOnly: aSelector) with: anInteger! ----- Method: SMarkSuite>>benchmarkNameForSelector: (in category 'helper') ----- benchmarkNameForSelector: selector "Extracts the actual name of the benchmark from the selector" (selector beginsWith: #bench) ifTrue: [ ^ selector copyFrom: 6 to: selector size]. ^ selector asSymbol ! ----- Method: SMarkSuite>>cleanUpInstanceVariables (in category 'running') ----- cleanUpInstanceVariables "Make sure all variables that are 'user variables' get cleaned" self class allInstVarNames do: [ :name | name = 'runner' ifFalse: [ self instVarNamed: name put: nil ] ]! ----- Method: SMarkSuite>>performCustomSelector:with: (in category 'benchmarking') ----- performCustomSelector: aSelector with: aPrefix | customSelector | customSelector := (aPrefix, aSelector capitalized) asSymbol. (self respondsTo: customSelector) ifTrue: [ self perform: customSelector].! ----- Method: SMarkSuite>>problemSize (in category 'benchmarking') ----- problemSize <omniUnenforced> "Hint for the OMOP that it is part of the meta infrastructure" runner ifNil: [^ self class defaultProblemSize]. runner problemSize ifNil: [^ self class defaultProblemSize]. ^ runner problemSize! ----- Method: SMarkSuite>>processResult:withTimer: (in category 'benchmarking') ----- processResult: anObject withTimer: aSMarkTimer "subclass responsability. You can verify your results here, or do things with the timer." ^self.! ----- Method: SMarkSuite>>run (in category 'benchmarking') ----- run "Executes all the benchmarks in the suite, coordinating with the runner when necessary" | potentialBenchmarkSelectors | selectedBenchmarks ifNotNil: [ potentialBenchmarkSelectors := selectedBenchmarks ] ifNil: [ potentialBenchmarkSelectors := self class allSelectors ]. potentialBenchmarkSelectors do: [ :selector | (self shouldRunSelector: selector) ifTrue: [ runner performBenchmark: selector ] ]. ! ----- Method: SMarkSuite>>runBenchmark: (in category 'benchmarking') ----- runBenchmark: aSelector [self setUp. self performCustomSelector: aSelector with: #setUp. runner timedBenchmarkExecution: aSelector] ensure: [ self performCustomSelector: aSelector with: #tearDown. self tearDown. self cleanUpInstanceVariables]! ----- Method: SMarkSuite>>runOnly: (in category 'benchmarking') ----- runOnly: aSymbol selectedBenchmarks := IdentitySet newFrom: { aSymbol }.! ----- Method: SMarkSuite>>runner (in category 'accessing') ----- runner ^ runner! ----- Method: SMarkSuite>>runner: (in category 'accessing') ----- runner: aRunner runner := aRunner.! ----- Method: SMarkSuite>>selectedBenchmarks (in category 'benchmarking') ----- selectedBenchmarks ^ selectedBenchmarks! ----- Method: SMarkSuite>>setUp (in category 'running') ----- setUp "It is the subclass' responsibility to set up the necessary environment for a benchmark" ^ self! ----- Method: SMarkSuite>>shouldRunSelector: (in category 'testing') ----- shouldRunSelector: selector "Tells whether the given selector is in the form bench*, and thus is a benchmark that should be executed." (selector includes: $:) ifTrue: [ ^ false ]. ^ selector beginsWith: #bench! ----- Method: SMarkSuite>>tearDown (in category 'running') ----- tearDown "It is the subclass' responsibility to clean up the environment after a benchmark" ^ self! Object subclass: #SMarkTimer instanceVariableNames: 'startTime elapsedTime name' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! !SMarkTimer commentStamp: '<historical>' prior: 0! A SMarkTimer is a simple timer. A subclass can measure alternative metrics, or for instance use different time sources. A subclass of SMarkRunner can then use the custom timer class by overriding SMarkRunner class >> #defaultTimer.! ----- Method: SMarkTimer class>>new: (in category 'instance creation') ----- new: aName | timer | timer := super new. timer name: aName. ^timer! ----- Method: SMarkTimer>>currentMillis (in category 'timing') ----- currentMillis ^ Time millisecondClockValue! ----- Method: SMarkTimer>>initialize (in category 'initialization') ----- initialize super initialize. elapsedTime := 0! ----- Method: SMarkTimer>>name (in category 'accessing') ----- name ^name! ----- Method: SMarkTimer>>name: (in category 'accessing') ----- name: aString name := aString ! ----- Method: SMarkTimer>>reset (in category 'timing') ----- reset startTime := 0. elapsedTime := 0.! ----- Method: SMarkTimer>>start (in category 'timing') ----- start startTime := self currentMillis.! ----- Method: SMarkTimer>>stop (in category 'timing') ----- stop | elapsedInThisPeriod current | current := self currentMillis. elapsedInThisPeriod := Time milliseconds: current since: startTime. elapsedTime := elapsedTime + elapsedInThisPeriod.! ----- Method: SMarkTimer>>totalTime (in category 'accessing') ----- totalTime ^elapsedTime! Object subclass: #SMarkTransporter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! !SMarkTransporter commentStamp: 'StefanMarr 4/5/2012 21:43' prior: 0! SMarkTransporter is a used to interact with a git-fileout system used in the RoarVM project to manage Smalltalk source code. SMarkTransporter is not actually a Transporter class, since there are currently no needs for customization. Thus, it is just a dummy class for future use, and to hold #transportersForFileOutMenu. ! ----- Method: SMarkTransporter class>>transportersForFileOutMenu (in category 'transporter') ----- transportersForFileOutMenu ^ { (Smalltalk at: #Transporter ifAbsent: [^#()]) forPackage: (PackageInfo named: 'SMark') }! Object subclass: #SMarkWeakScalingRunnerExecutor instanceVariableNames: 'numInnerIterations benchmarkSelector suite runner' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-SMark'! ----- Method: SMarkWeakScalingRunnerExecutor class>>createFor:for:with:and: (in category 'as yet unclassified') ----- createFor: aSelector for: numIterations with: aRunner and: aSuite | o | o := self new. o runner: aRunner. o suite: aSuite. o innerIterations: numIterations. o benchmarkSelector: aSelector. ^ ([ o run ] newProcess)! ----- Method: SMarkWeakScalingRunnerExecutor>>benchmarkSelector: (in category 'accessing') ----- benchmarkSelector: aSelector benchmarkSelector := aSelector! ----- Method: SMarkWeakScalingRunnerExecutor>>innerIterations: (in category 'accessing') ----- innerIterations: anInt numInnerIterations := anInt! ----- Method: SMarkWeakScalingRunnerExecutor>>run (in category 'benchmarking') ----- run 1 to: numInnerIterations do: [:i | suite perform: benchmarkSelector.]. runner executorCompleted.! ----- Method: SMarkWeakScalingRunnerExecutor>>runner: (in category 'accessing') ----- runner: aRunner runner := aRunner! ----- Method: SMarkWeakScalingRunnerExecutor>>suite: (in category 'accessing') ----- suite: aSuite suite := aSuite! Object subclass: #ShootoutBody instanceVariableNames: 'x y z vx vy vz mass' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Shootout'! ----- Method: ShootoutBody class>>daysPerYear (in category 'constants') ----- daysPerYear ^365.24! ----- Method: ShootoutBody class>>jupiter (in category 'constants') ----- jupiter ^self new x: 4.84143144246472090 y: -1.16032004402742839 z: -1.03622044471123109e-1 vx: 1.66007664274403694e-3 * self daysPerYear vy: 7.69901118419740425e-3 * self daysPerYear vz: -6.90460016972063023e-5 * self daysPerYear mass: 9.54791938424326609e-4 * self solarMass! ----- Method: ShootoutBody class>>neptune (in category 'constants') ----- neptune ^self new x: 1.53796971148509165e1 y: -2.59193146099879641e1 z: 1.79258772950371181e-1 vx: 2.68067772490389322e-3 * self daysPerYear vy: 1.62824170038242295e-3 * self daysPerYear vz: -9.51592254519715870e-5 * self daysPerYear mass: 5.15138902046611451e-5 * self solarMass! ----- Method: ShootoutBody class>>pi (in category 'constants') ----- pi ^3.141592653589793! ----- Method: ShootoutBody class>>saturn (in category 'constants') ----- saturn ^self new x: 8.34336671824457987 y: 4.12479856412430479 z: -4.03523417114321381e-1 vx: -2.76742510726862411e-3 * self daysPerYear vy: 4.99852801234917238e-3 * self daysPerYear vz: 2.30417297573763929e-5 * self daysPerYear mass: 2.85885980666130812e-4 * self solarMass! ----- Method: ShootoutBody class>>solarMass (in category 'constants') ----- solarMass ^4.0 * self pi * self pi! ----- Method: ShootoutBody class>>sun (in category 'constants') ----- sun ^self new x: 0.0 y: 0.0 z: 0.0 vx: 0.0 vy: 0.0 vz: 0.0 mass: self solarMass! ----- Method: ShootoutBody class>>uranus (in category 'constants') ----- uranus ^self new x: 1.28943695621391310e1 y: -1.51111514016986312e1 z: -2.23307578892655734e-1 vx: 2.96460137564761618e-3 * self daysPerYear vy: 2.37847173959480950e-3 * self daysPerYear vz: -2.96589568540237556e-5 * self daysPerYear mass: 4.36624404335156298e-5 * self solarMass! ----- Method: ShootoutBody>>addMomentumTo: (in category 'nbody') ----- addMomentumTo: anArray anArray at: 1 put: (anArray at: 1) + (vx * mass). anArray at: 2 put: (anArray at: 2) + (vy * mass). anArray at: 3 put: (anArray at: 3) + (vz * mass). ^anArray! ----- Method: ShootoutBody>>and:velocityAfter: (in category 'nbody') ----- and: aBody velocityAfter: dt | dx dy dz distance mag | dx := x - aBody x. dy := y - aBody y. dz := z - aBody z. distance := ((dx*dx) + (dy*dy) + (dz*dz)) sqrt. mag := dt / (distance * distance * distance). self decreaseVelocity: dx y: dy z: dz m: aBody mass * mag. aBody increaseVelocity: dx y: dy z: dz m: mass * mag! ----- Method: ShootoutBody>>decreaseVelocity:y:z:m: (in category 'nbody') ----- decreaseVelocity: dx y: dy z: dz m: m vx := vx - (dx * m). vy := vy - (dy * m). vz := vz - (dz * m)! ----- Method: ShootoutBody>>increaseVelocity:y:z:m: (in category 'nbody') ----- increaseVelocity: dx y: dy z: dz m: m vx := vx + (dx * m). vy := vy + (dy * m). vz := vz + (dz * m)! ----- Method: ShootoutBody>>kineticEnergy (in category 'nbody') ----- kineticEnergy ^0.5 * mass * ((vx * vx) + (vy * vy) + (vz * vz))! ----- Method: ShootoutBody>>mass (in category 'accessing') ----- mass ^mass! ----- Method: ShootoutBody>>offsetMomentum: (in category 'nbody') ----- offsetMomentum: anArray | m | m := self class solarMass. vx := (anArray at: 1) negated / m. vy := (anArray at: 2) negated / m. vz := (anArray at: 3) negated / m! ----- Method: ShootoutBody>>positionAfter: (in category 'nbody') ----- positionAfter: dt x := x + (dt * vx). y := y + (dt * vy). z := z + (dt * vz)! ----- Method: ShootoutBody>>potentialEnergy: (in category 'nbody') ----- potentialEnergy: aBody | dx dy dz distance | dx := x - aBody x. dy := y - aBody y. dz := z - aBody z. distance := ((dx*dx) + (dy*dy) + (dz*dz)) sqrt. ^mass * aBody mass / distance! ----- Method: ShootoutBody>>x (in category 'accessing') ----- x ^x! ----- Method: ShootoutBody>>x:y:z:vx:vy:vz:mass: (in category 'accessing') ----- x: d1 y: d2 z: d3 vx: d4 vy: d5 vz: d6 mass: d7 x := d1. y := d2. z := d3. vx := d4. vy := d5. vz := d6. mass := d7! ----- Method: ShootoutBody>>y (in category 'accessing') ----- y ^y! ----- Method: ShootoutBody>>z (in category 'accessing') ----- z ^z! Object subclass: #ShootoutChameneosColour instanceVariableNames: 'color' classVariableNames: 'Blue Red Yellow' poolDictionaries: '' category: 'CogBenchmarks-Shootout'! ----- Method: ShootoutChameneosColour class>>blue (in category 'accessing') ----- blue ^Blue! ----- Method: ShootoutChameneosColour class>>blue: (in category 'accessing') ----- blue: anObject Blue := anObject! ----- Method: ShootoutChameneosColour class>>createBlue (in category 'initialize-release') ----- createBlue "comment stating purpose of message" ^super new color: #blue! ----- Method: ShootoutChameneosColour class>>createRed (in category 'initialize-release') ----- createRed "comment stating purpose of message" ^super new color: #red! ----- Method: ShootoutChameneosColour class>>createYellow (in category 'initialize-release') ----- createYellow "comment stating purpose of message" ^super new color: #yellow! ----- Method: ShootoutChameneosColour class>>generateReportOfColoursOn: (in category 'printing') ----- generateReportOfColoursOn: readOut | colours | colours := Array with: Blue with: Red with: Yellow. colours do: [:aColour | colours do: [:anotherColour | aColour printOn: readOut. readOut nextPutAll: ' + '. anotherColour printOn: readOut. readOut nextPutAll: ' -> '. (aColour complementaryColourFor: anotherColour) printOn: readOut. readOut nl]]. ^readOut! ----- Method: ShootoutChameneosColour class>>initialize (in category 'initialize-release') ----- initialize "self initialize" Red := self createRed. Blue := self createBlue. Yellow := self createYellow! ----- Method: ShootoutChameneosColour class>>red (in category 'accessing') ----- red ^Red! ----- Method: ShootoutChameneosColour class>>red: (in category 'accessing') ----- red: anObject Red := anObject! ----- Method: ShootoutChameneosColour class>>yellow (in category 'accessing') ----- yellow ^Yellow! ----- Method: ShootoutChameneosColour class>>yellow: (in category 'accessing') ----- yellow: anObject Yellow := anObject! ----- Method: ShootoutChameneosColour>>color (in category 'accessing') ----- color ^color! ----- Method: ShootoutChameneosColour>>color: (in category 'accessing') ----- color: aColor color := aColor! ----- Method: ShootoutChameneosColour>>complementaryColourFor: (in category 'as yet unclassified') ----- complementaryColourFor: aChameneosColour "determine the complementary colour defined as..." self == aChameneosColour ifTrue: [^self]. self isBlue ifTrue: [aChameneosColour isRed ifTrue: [^self class yellow] ifFalse: [^self class red]]. self isRed ifTrue: [aChameneosColour isBlue ifTrue: [^self class yellow] ifFalse: [^self class blue]]. aChameneosColour isBlue ifTrue: [^self class red] ifFalse: [^self class blue]! ----- Method: ShootoutChameneosColour>>hasSameColorAs: (in category 'testing') ----- hasSameColorAs: aChameneos ^self color == aChameneos color! ----- Method: ShootoutChameneosColour>>isBlue (in category 'testing') ----- isBlue ^self == self class blue! ----- Method: ShootoutChameneosColour>>isRed (in category 'testing') ----- isRed ^self == self class red! ----- Method: ShootoutChameneosColour>>isYellow (in category 'testing') ----- isYellow ^self == self class yellow! ----- Method: ShootoutChameneosColour>>printOn: (in category 'printing') ----- printOn: aStream aStream nextPutAll: self color! Object subclass: #ShootoutCreature instanceVariableNames: 'creatureName colour selfMet creaturesMet' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Shootout'! ----- Method: ShootoutCreature class>>withName:colour: (in category 'initialize-release') ----- withName: aName colour: aColour ^(ShootoutCreature new initialize) name: aName; colour: aColour! ----- Method: ShootoutCreature>>colour (in category 'accessing') ----- colour ^colour! ----- Method: ShootoutCreature>>colour: (in category 'accessing') ----- colour: anObject colour := anObject! ----- Method: ShootoutCreature>>creaturesMet (in category 'accessing') ----- creaturesMet ^creaturesMet! ----- Method: ShootoutCreature>>creaturesMet: (in category 'accessing') ----- creaturesMet: anObject creaturesMet := anObject! ----- Method: ShootoutCreature>>initialize (in category 'initialize-release') ----- initialize selfMet := 0. creaturesMet := 0! ----- Method: ShootoutCreature>>name (in category 'accessing') ----- name ^creatureName! ----- Method: ShootoutCreature>>name: (in category 'accessing') ----- name: anObject creatureName := anObject! ----- Method: ShootoutCreature>>selfMet (in category 'accessing') ----- selfMet ^selfMet! ----- Method: ShootoutCreature>>selfMet: (in category 'accessing') ----- selfMet: anObject ^selfMet := anObject! ----- Method: ShootoutCreature>>visitMall: (in category 'controlling') ----- visitMall: mall [| partner | partner := mall visitWith: self. partner ifNotNil: [colour := colour complementaryColourFor: partner colour. self == partner ifTrue: [selfMet := selfMet + 1]. creaturesMet := creaturesMet + 1]. partner isNil] whileFalse! Object subclass: #ShootoutMall instanceVariableNames: 'guard maxRendezvous open process queue cache pairCache' classVariableNames: 'Units' poolDictionaries: '' category: 'CogBenchmarks-Shootout'! ----- Method: ShootoutMall class>>createAllowing: (in category 'initialize-release') ----- createAllowing: maxRendezvous "Private" ^self basicNew initialize maxRendezvous: maxRendezvous! ----- Method: ShootoutMall class>>createCreaturesWith: (in category 'initialize-release') ----- createCreaturesWith: aCollectionOfColours "Private" | aName | aName := 0. ^aCollectionOfColours collect: [:aColour | aName := aName + 1. ShootoutCreature withName: aName colour: aColour]! ----- Method: ShootoutMall class>>generateReportFor:printOn: (in category 'printing') ----- generateReportFor: creatures printOn: stream | sum | sum := creatures inject: 0 into: [:accum :each | accum + each creaturesMet]. creatures do: [:aCreature | aCreature creaturesMet printOn: stream. stream space; nextPutAll: (self units at: aCreature selfMet + 1); nl]. stream space. sum printString do: [:el | stream nextPutAll: (self units at: el digitValue + 1)] separatedBy: [stream space]. ^stream! ----- Method: ShootoutMall class>>generateReportForColours:printOn: (in category 'printing') ----- generateReportForColours: colours printOn: stream stream space. colours do: [:colour | colour printOn: stream] separatedBy: [stream space]. ^stream! ----- Method: ShootoutMall class>>initialize (in category 'initialize-release') ----- initialize "self initialize" Units := #('zero' 'one' 'two' 'three' 'four' 'five' 'six' 'seven' 'eight' 'nine')! ----- Method: ShootoutMall class>>new (in category 'initialize-release') ----- new ^self shouldNotImplement! ----- Method: ShootoutMall class>>openMall:forCreatures:usingGuard: (in category 'private') ----- openMall: aMall forCreatures: creatures usingGuard: sema | processes | processes := creatures collect: [:aCreature | [aCreature visitMall: aMall. sema signal] newProcess]. processes do: [:proc | proc priority: Processor userBackgroundPriority. proc resume]! ----- Method: ShootoutMall class>>openMallWith:forNumberOfMeets: (in category 'initialize-release') ----- openMallWith: aCollectionOfColours forNumberOfMeets: aNumber | mall creatures guard | mall := self createAllowing: aNumber. mall run. creatures := self createCreaturesWith: aCollectionOfColours. guard := Semaphore new. self openMall: mall forCreatures: creatures usingGuard: guard. self waitForClosingOfMall: mall withCreatures: creatures usingGuard: guard. ^creatures! ----- Method: ShootoutMall class>>runBenchMark:on: (in category 'public') ----- runBenchMark: number on: anOutputStream "self runBenchMark: 60000 on: Transcript." | firstTestColours secondTestColours blue red yellow creatures | blue := ShootoutChameneosColour blue. red := ShootoutChameneosColour red. yellow := ShootoutChameneosColour yellow. firstTestColours := Array with: blue with: red with: yellow. secondTestColours := (OrderedCollection new) add: blue; add: red; add: yellow; add: red; add: yellow; add: blue; add: red; add: yellow; add: red; add: blue; yourself. (ShootoutChameneosColour generateReportOfColoursOn: anOutputStream) nl. (self generateReportForColours: firstTestColours printOn: anOutputStream) nl. creatures := ShootoutMall openMallWith: firstTestColours forNumberOfMeets: number. (self generateReportFor: creatures printOn: anOutputStream) nl; nl. (self generateReportForColours: secondTestColours printOn: anOutputStream) nl. creatures := ShootoutMall openMallWith: secondTestColours forNumberOfMeets: number. (self generateReportFor: creatures printOn: anOutputStream) nl; nl! ----- Method: ShootoutMall class>>units (in category 'accessing') ----- units ^Units! ----- Method: ShootoutMall class>>waitForClosingOfMall:withCreatures:usingGuard: (in category 'private') ----- waitForClosingOfMall: aMall withCreatures: creatures usingGuard: guard creatures size timesRepeat: [guard wait]. aMall close! ----- Method: ShootoutMall>>close (in category 'controlling') ----- close open := false! ----- Method: ShootoutMall>>initialize (in category 'initialize-release') ----- initialize guard := Semaphore forMutualExclusion. queue := SharedQueue new. cache := OrderedCollection new. 1 to: 10 do: [:x | cache add: ShootoutPair new]! ----- Method: ShootoutMall>>maxRendezvous: (in category 'accessing') ----- maxRendezvous: max maxRendezvous := max! ----- Method: ShootoutMall>>obtainPair (in category 'private') ----- obtainPair ^cache removeFirst! ----- Method: ShootoutMall>>processVisitors (in category 'private') ----- processVisitors [open] whileTrue: [1 to: maxRendezvous do: [:x | | first second | first := queue next. second := queue next. self setPartnersOn: first and: second. first signal. second signal]. [queue isEmpty] whileFalse: [queue next signal]]. process terminate. process := nil! ----- Method: ShootoutMall>>releasePair: (in category 'private') ----- releasePair: pair pair release. cache addFirst: pair! ----- Method: ShootoutMall>>run (in category 'initialize-release') ----- run open := true. process ifNil: [process := [self processVisitors] newProcess. process priority: Processor userBackgroundPriority -1 ]. process resume! ----- Method: ShootoutMall>>setPartnersOn:and: (in category 'private') ----- setPartnersOn: first and: second first partner: second me. second partner: first me. ! ----- Method: ShootoutMall>>shutdown (in category 'private') ----- shutdown [queue isEmpty] whileFalse: [queue next signal]. process terminate. process := nil! ----- Method: ShootoutMall>>visitWith: (in category 'controlling') ----- visitWith: aChameneos | pair partner | pair := self obtainPair. pair me: aChameneos. queue nextPut: pair. pair wait. partner := pair partner. self releasePair: pair. ^partner! Object subclass: #ShootoutNBodySystem instanceVariableNames: 'bodies' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Shootout'! ----- Method: ShootoutNBodySystem>>after: (in category 'nbody') ----- after: dt 1 to: bodies size do: [:i| i+1 to: bodies size do: [:j| (bodies at: i) and: (bodies at: j) velocityAfter: dt]. ]. bodies do: [:each| each positionAfter: dt]! ----- Method: ShootoutNBodySystem>>energy (in category 'nbody') ----- energy | e | e := 0.0. 1 to: bodies size do: [:i| e := e + (bodies at: i) kineticEnergy. i+1 to: bodies size do: [:j| e := e - ((bodies at: i) potentialEnergy: (bodies at: j))]. ]. ^e! ----- Method: ShootoutNBodySystem>>initialize (in category 'initialize-release') ----- initialize bodies := (OrderedCollection new add: ShootoutBody sun; add: ShootoutBody jupiter; add: ShootoutBody saturn; add: ShootoutBody uranus; add: ShootoutBody neptune; yourself) asArray. bodies first offsetMomentum: (bodies inject: (Array with: 0.0 with: 0.0 with: 0.0) into: [:m :each | each addMomentumTo: m])! Object subclass: #ShootoutPair instanceVariableNames: 'partner me sema' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Shootout'! ----- Method: ShootoutPair class>>new (in category 'instance creation') ----- new "Answer a newly created and initialized instance." ^super new initialize.! ----- Method: ShootoutPair class>>with: (in category 'instance creation') ----- with: me "Answer a newly created and initialized instance." self halt. ^super new initialize me: me! ----- Method: ShootoutPair>>initialize (in category 'initialize-release') ----- initialize "Initialize a newly created instance. This method must answer the receiver." partner := nil. me := nil. sema := Semaphore new. ^self! ----- Method: ShootoutPair>>me (in category 'accessing') ----- me ^me! ----- Method: ShootoutPair>>me: (in category 'accessing') ----- me: anObject me := anObject! ----- Method: ShootoutPair>>partner (in category 'accessing') ----- partner ^partner! ----- Method: ShootoutPair>>partner: (in category 'accessing') ----- partner: anObject partner := anObject! ----- Method: ShootoutPair>>release (in category 'initialize-release') ----- release partner:=nil.! ----- Method: ShootoutPair>>signal (in category 'initialize-release') ----- signal sema signal! ----- Method: ShootoutPair>>wait (in category 'initialize-release') ----- wait sema wait! Object subclass: #ShootoutTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Shootout'! ----- Method: ShootoutTests class>>arg (in category 'platform') ----- arg 3 to: 5 do: [:i| (SmalltalkImage current getSystemAttribute: i) ifNotNil: [:aString| aString asInteger ifNotNil: [:arg| ^arg]]]. ^nil! ----- Method: ShootoutTests class>>binarytrees (in category 'benchmark scripts') ----- binarytrees self binarytrees: self arg to: self stdout. ^''! ----- Method: ShootoutTests class>>binarytrees:to: (in category 'benchmarking') ----- binarytrees: n to: output | minDepth maxDepth stretchDepth check longLivedTree iterations | minDepth := 4. maxDepth := minDepth + 2 max: n. stretchDepth := maxDepth + 1. check := (ShootoutTreeNode bottomUpTree: 0 depth: stretchDepth) itemCheck. output nextPutAll: 'stretch tree of depth '; print: stretchDepth; tab; nextPutAll: ' check: '; print: check; nl. longLivedTree := ShootoutTreeNode bottomUpTree: 0 depth: maxDepth. minDepth to: maxDepth by: 2 do: [:depth| iterations := 1 bitShift: maxDepth - depth + minDepth. check := 0. 1 to: iterations do: [:i| check := check + (ShootoutTreeNode bottomUpTree: i depth: depth) itemCheck. check := check + (ShootoutTreeNode bottomUpTree: -1*i depth: depth) itemCheck ]. output print: (2*iterations); tab; nextPutAll: ' trees of depth '; print: depth; tab; nextPutAll: ' check: '; print: check; nl ]. output nextPutAll: 'long lived tree of depth '; print: maxDepth; tab; nextPutAll: ' check: '; print: longLivedTree itemCheck; nl! ----- Method: ShootoutTests class>>chameneosredux2 (in category 'benchmark scripts') ----- chameneosredux2 self chameneosredux: self arg to: self stdout. ^''! ----- Method: ShootoutTests class>>chameneosredux:to: (in category 'benchmarking') ----- chameneosredux: arg to: aStream ShootoutMall runBenchMark: arg on: aStream! ----- Method: ShootoutTests class>>collectReferenceTimes (in category 'benchmark scripts') ----- collectReferenceTimes "Run the benchmarks 3 times and take their average, e.g. suitable for filling in values for referenceTimesForClosureInterpreter" "ShootoutTests collectReferenceTimes" | n refs | Transcript clear. n := 3. refs := (1 to: n) collect: [:i| ShootoutTests runAllToInternalStream]. ^{ refs. (1 to: refs first size) collect: [:i| ((refs inject: 0 into: [:sum :ref| (ref at: i) + sum]) / n) rounded] }! ----- Method: ShootoutTests class>>nbody (in category 'benchmark scripts') ----- nbody self nbody: self arg to: self stdout! ----- Method: ShootoutTests class>>nbody:to: (in category 'benchmarking') ----- nbody: count to: output | bodies | bodies := ShootoutNBodySystem new initialize. output print: bodies energy digits: 9; cr. count timesRepeat: [bodies after: 0.01]. output print: bodies energy digits: 9; cr. ^''! ----- Method: ShootoutTests class>>profileAll (in category 'profiling') ----- profileAll "self profileAll" | stream | stream := DummyStream new. self nbody: 200000 "20000000" to: stream. self binarytrees: 15 to: stream. self chameneosredux: 260000 to: stream. self threadring: 10000000 to: stream! ----- Method: ShootoutTests class>>referenceArgs (in category 'benchmark scripts') ----- referenceArgs ^self referenceTimesAndArgsForClosureInterpreter collect: [:ea| ea last]! ----- Method: ShootoutTests class>>referenceTimesAndArgsForClosureInterpreter (in category 'benchmark scripts') ----- referenceTimesAndArgsForClosureInterpreter "Interpreter + Closures VM (Mac Cocoa 5.7b3 27-Aug-10 >7BCAB029-A835-4D12-946D-4AB7083D2955< VMMaker versionString 4.4.9) on Eliot's 2012 vintage 2.2GHz Intel (quad) Core i7 MacBook Pro" ^Dictionary new at: #nbody put: #(40903 2000000); at: #binarytrees put: #(30573 17); at: #chameneosredux put: #(30722 2000000); at: #threadring put: #(9148 30000000); yourself! ----- Method: ShootoutTests class>>referenceTimesForClosureInterpreter (in category 'benchmark scripts') ----- referenceTimesForClosureInterpreter ^self referenceTimesAndArgsForClosureInterpreter collect: [:ea| ea first]! ----- Method: ShootoutTests class>>report:time:reference:on: (in category 'reporting') ----- report: name time: millisecs reference: reference on: aStream aStream cr; nextPutAll: name; cr; nextPutAll: ' took '; print: millisecs / 1000.0; nextPutAll: ' seconds'; cr; flush; nextPutAll: 'ratio: '; print: ((millisecs / reference) roundTo: 0.001); nextPutAll: ' % change: '; print: ((millisecs - reference * 100 / reference) roundTo: 0.01); nextPut: $%; cr; flush! ----- Method: ShootoutTests class>>runAllToDummyStream (in category 'benchmark scripts') ----- runAllToDummyStream "Transcript clear. self runAllToDummyStream" ^self runAllToDummyStreamVs: self referenceTimesForClosureInterpreter! ----- Method: ShootoutTests class>>runAllToDummyStreamVs: (in category 'benchmark scripts') ----- runAllToDummyStreamVs: referenceTimes "Transcript clear. self runAllToDummyStreamVs: self referenceTimesForClosureInterpreter" "Transcript clear. self runAllToDummyStreamVs: self referenceTimesForSqueakVM" ^self runAllToDummyStreamVs: referenceTimes reportTo: Transcript! ----- Method: ShootoutTests class>>runAllToDummyStreamVs:reportTo: (in category 'benchmark scripts') ----- runAllToDummyStreamVs: referenceTimes reportTo: aStream "Transcript clear. self runAllToDummyStreamVs: self referenceTimesForClosureInterpreter" "Transcript clear. self runAllToDummyStreamVs: self referenceTimesForSqueakVM" | times ratios geometricMean | times := Array new writeStream. ratios := Array new writeStream. (self standardSuiteTo: DummyStream basicNew) do: [:block | | benchmark reference t | benchmark := (self selectorForSimpleBlock: block) copyUpTo: $:. reference := referenceTimes at: benchmark asSymbol. Smalltalk garbageCollect. times nextPut: (t := Time millisecondsToRun: block). ratios nextPut: t asFloat / reference. self report: block decompile printString time: t reference: reference on: aStream]. geometricMean := (ratios contents inject: 1 into: [:m :n| m * n]) raisedTo: 1 / ratios position. aStream nextPutAll: 'geometric mean '; print: (geometricMean roundTo: 0.001); nextPutAll: ' average speedup '; print: ((geometricMean - 1 * 100) roundTo: 0.01); nextPut: $%; cr; cr; flush. ^times contents! ----- Method: ShootoutTests class>>runAllToInternalStream (in category 'benchmark scripts') ----- runAllToInternalStream "Transcript clear. self runAllToInternalStream" ^self runAllToInternalStreamVs: self referenceTimesForClosureInterpreter! ----- Method: ShootoutTests class>>runAllToInternalStreamVs: (in category 'benchmark scripts') ----- runAllToInternalStreamVs: referenceTimes "Transcript clear. self runAllToInternalStreamVs: self referenceTimesForClosureInterpreter" "Transcript clear. self runAllToInternalStreamVs: self referenceTimesForSqueakVM" | times ratios geometricMean | times := Array new writeStream. ratios := Array new writeStream. (self standardSuiteTo: (ByteString new: 10000) writeStream) do: [:block | | benchmark reference t | benchmark := (self selectorForSimpleBlock: block) copyUpTo: $:. reference := referenceTimes at: benchmark asSymbol. Smalltalk garbageCollect. times nextPut: (t := Time millisecondsToRun: block). ratios nextPut: t asFloat / reference. self report: block decompile printString time: t reference: reference on: Transcript]. geometricMean := (ratios contents inject: 1 into: [:m :n| m * n]) raisedTo: 1 / ratios position. Transcript nextPutAll: 'geometric mean '; print: (geometricMean roundTo: 0.001); nextPutAll: ' average speedup '; print: ((geometricMean - 1 * 100) roundTo: 0.01); nextPut: $%; cr; cr; flush. ^times contents! ----- Method: ShootoutTests class>>runAllToTranscript (in category 'benchmark scripts') ----- runAllToTranscript "Transcript clear. self runAllToTranscript" ^self runAllToTranscriptVs: self referenceTimesForClosureInterpreter! ----- Method: ShootoutTests class>>runAllToTranscriptVs: (in category 'benchmark scripts') ----- runAllToTranscriptVs: referenceTimes "Transcript clear. self runAllToTranscriptVs: self referenceTimesForClosureInterpreter" "Transcript clear. self runAllToTranscriptVs: self referenceTimesForSqueakVM" | times ratios geometricMean | times := Array new writeStream. ratios := Array new writeStream. (self standardSuiteTo: Transcript) do: [:block | | benchmark reference t | benchmark := (self selectorForSimpleBlock: block) copyUpTo: $:. reference := referenceTimes at: benchmark asSymbol. Smalltalk garbageCollect. times nextPut: (t := Time millisecondsToRun: block). ratios nextPut: t asFloat / reference. self report: block decompile printString time: t reference: reference on: Transcript]. geometricMean := (ratios contents inject: 1 into: [:m :n| m * n]) raisedTo: 1 / ratios position. Transcript nextPutAll: 'geometric mean '; print: (geometricMean roundTo: 0.001); nextPutAll: ' average speedup '; print: ((geometricMean - 1 * 100) roundTo: 0.01); nextPut: $%; cr; cr; flush. ^times contents! ----- Method: ShootoutTests class>>selectorForSimpleBlock: (in category 'benchmark scripts') ----- selectorForSimpleBlock: aBlock | is | is := InstructionStream on: aBlock method. is pc: aBlock startpc. is scanFor: [:x| | selectorOrScanner | (selectorOrScanner := is selectorToSendOrSelf) ~~ is ifTrue: [^selectorOrScanner]. false]. ^nil! ----- Method: ShootoutTests class>>standardSuiteTo: (in category 'benchmark scripts') ----- standardSuiteTo: aStream "revised up from { [self nbody: 200000 to: stream]. [self binarytrees: 15 to: stream]. [self chameneosredux: 260000 to: stream]. [self threadring: 10000000 to: stream] } on 6/15/2014" | reference nbodyCount binaryTreeDepth chameneosCount threadringCount | reference := self referenceTimesAndArgsForClosureInterpreter. nbodyCount := (reference at: #nbody) last. binaryTreeDepth := (reference at: #binarytrees) last. chameneosCount := (reference at: #chameneosredux) last. threadringCount := (reference at: #threadring) last. ^{ [self nbody: nbodyCount to: aStream]. [self binarytrees: binaryTreeDepth to: aStream]. [self chameneosredux: chameneosCount to: aStream]. [self threadring: threadringCount to: aStream] }! ----- Method: ShootoutTests class>>stdin (in category 'platform') ----- stdin ^StandardFileStream stdIn! ----- Method: ShootoutTests class>>stdout (in category 'platform') ----- stdout ^StandardFileStream stdout! ----- Method: ShootoutTests class>>threadRing:output: (in category 'benchmarking') ----- threadRing: aSemaphore output: output | first last | 503 to: 1 by: -1 do: [:i| first := ShootoutThread named: i next: first done: aSemaphore output: output. last isNil ifTrue: [ last := first ]. ]. last nextThread: first. ^first ! ----- Method: ShootoutTests class>>threadring (in category 'benchmark scripts') ----- threadring self threadring: self arg to: self stdout. ^''! ----- Method: ShootoutTests class>>threadring:to: (in category 'benchmarking') ----- threadring: arg to: output | done | (self threadRing: (done := Semaphore new) output: output) takeToken: arg. done wait! Object subclass: #ShootoutThread instanceVariableNames: 'name nextThread token semaphore done output' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Shootout'! ----- Method: ShootoutThread class>>named:next:done:output: (in category 'instance creation') ----- named: anInteger next: aThread done: aSemaphore output: aStream ^self new name: anInteger; nextThread: aThread; done: aSemaphore; output: aStream; fork ! ----- Method: ShootoutThread class>>new (in category 'instance creation') ----- new ^self basicNew semaphore: Semaphore new ! ----- Method: ShootoutThread>>done: (in category 'accessing') ----- done: aSemaphore done := aSemaphore ! ----- Method: ShootoutThread>>fork (in category 'accessing') ----- fork [ self run ] fork ! ----- Method: ShootoutThread>>name: (in category 'accessing') ----- name: anInteger name := anInteger ! ----- Method: ShootoutThread>>nextThread: (in category 'accessing') ----- nextThread: aThread nextThread := aThread ! ----- Method: ShootoutThread>>output: (in category 'accessing') ----- output: anObject "Set the value of output" output := anObject! ----- Method: ShootoutThread>>run (in category 'accessing') ----- run [ self tokenNotDone ] whileTrue: [ nextThread takeToken: token - 1 ]. output print: name. output name = 'stdout' ifTrue: [output nl] ifFalse: [output cr; flush]. done signal ! ----- Method: ShootoutThread>>semaphore: (in category 'accessing') ----- semaphore: aSemaphore semaphore := aSemaphore ! ----- Method: ShootoutThread>>takeToken: (in category 'accessing') ----- takeToken: x token := x. semaphore signal ! ----- Method: ShootoutThread>>tokenNotDone (in category 'accessing') ----- tokenNotDone semaphore wait. ^token > 0 ! Object subclass: #ShootoutTreeNode instanceVariableNames: 'left right item' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-Shootout'! ----- Method: ShootoutTreeNode class>>bottomUpTree:depth: (in category 'instance creation') ----- bottomUpTree: anItem depth: anInteger ^(anInteger > 0) ifTrue: [ self left: (self bottomUpTree: 2*anItem - 1 depth: anInteger - 1) right: (self bottomUpTree: 2*anItem depth: anInteger - 1) item: anItem ] ifFalse: [self left: nil right: nil item: anItem]! ----- Method: ShootoutTreeNode class>>left:right:item: (in category 'instance creation') ----- left: leftChild right: rightChild item: anItem ^(super new) left: leftChild right: rightChild item: anItem! ----- Method: ShootoutTreeNode>>itemCheck (in category 'accessing') ----- itemCheck ^left isNil ifTrue: [item] ifFalse: [item + (left itemCheck - right itemCheck)]! ----- Method: ShootoutTreeNode>>left:right:item: (in category 'initialize-release') ----- left: leftChild right: rightChild item: anItem left := leftChild. right := rightChild. item := anItem! ----- Method: DummyStream>>cr (in category '*CogBenchmarks-Shootout-platform') ----- cr! ----- Method: DummyStream>>nl (in category '*CogBenchmarks-Shootout-platform') ----- nl "do nothing"! ----- Method: DummyStream>>print:digits: (in category '*CogBenchmarks-Shootout-platform') ----- print: number digits: decimalPlaces "do nothing"! ----- Method: DummyStream>>print:paddedTo: (in category '*CogBenchmarks-Shootout-platform') ----- print: number paddedTo: width "do nothing"! ----- Method: DummyStream>>space (in category '*CogBenchmarks-Shootout-platform') ----- space! ----- Method: DummyStream>>tab (in category '*CogBenchmarks-Shootout-platform') ----- tab! OrderedCollection subclass: #DBPlan instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CogBenchmarks-DeltaBlue'! !DBPlan commentStamp: '<historical>' prior: 0! A Plan is an ordered list of constraints to be executed in sequence to resatisfy all currently satisfiable constraints in the face of one or more changing inputs.! ----- Method: DBPlan>>execute (in category 'planning') ----- execute "Execute my constraints in order." self do: [: c | c execute].! ----- Method: Stream>>nl (in category '*CogBenchmarks-Shootout-platform') ----- nl self nextPut: Character lf! ----- Method: Stream>>print:digits: (in category '*CogBenchmarks-Shootout-platform') ----- print: number digits: decimalPlaces | precision rounded | decimalPlaces <= 0 ifTrue: [^ number rounded printString]. precision := Utilities floatPrecisionForDecimalPlaces: decimalPlaces. rounded := number roundTo: precision. self nextPutAll: ((rounded asScaledDecimal: decimalPlaces) printString copyUpTo: $s)! ----- Method: Stream>>print:paddedTo: (in category '*CogBenchmarks-Shootout-platform') ----- print: number paddedTo: width self nextPutAll: (number printStringLength: width padded: false)!

1 0

Re: [squeak-dev] FileDoesNotExistException on existing changes file during trunk update
by Eliot Miranda 02 Sep '14

02 Sep '14

Hi Bert, On Mon, Sep 1, 2014 at 7:13 AM, Bert Freudenberg <bert(a)freudenbergs.de> wrote: > On 01.09.2014, at 15:56, Eliot Miranda <eliot.miranda(a)gmail.com> wrote: > > >> Another thought is that given the abundance of memory these days, we > might cache both sources and changes in main memory (which would also speed > up full-text searches). > > > > Pharo is planning to eliminate them altogether which is more coherent > than caching them. > > That's another discussion, but it might be a step towards that. > > > But IMO the solution is easy, maintain a *single* read-only copy of the > sources and changes files in SourceFilesArray (or whatever the class is > called; I'm on my phone) and read source through them instead of reopen ing > the damn things all the time. > > Except that Squeak files do not maintain an independent file position > pointer, so reading from different positions in the same file is not > thread-safe. That's why the file is opened again. > Can you explain more. I don't understand. As I see it every file instance has its own FILE structure so I don't understand how this can be so. Files are derived from FilePlugin's primitiveFileOpen function. That is implemented in terms of fileOpenNamesizewritesecure, which allocates a ByteArray to hold state (so no two Smalltalk files share state) and then uses sqFileOpen to open the underlying file and fill in the state. The C library implementation of sqFileOpen in platforms/Cross/plugins/FilePlugin/sqFilePluginBasicPrims.c uses fopen et al, again creating unique state. So I don't see how having a writable Smalltalk file and a separate read-only Smalltalk file on the sources and changes can result in other than two separate independent file pointers. There *is* an issue with the structure of file access in the debugger. If one were to step through execution of accessing source from e.g. the read-only sources file then the very act of fetching sources for the methods being displayed would confuse the state in the file one was observing through the debugger. But that's hardly a new situation (one can get into a similar situation with the current setup), and the debugger could ease the situation by wrapping source access with something that reset the file's buffer etc. > > > Then the file's own buffers will provide done caching. Annoying that I > write this code in 2008 for newspeak but we still rely on the mad "run the > GC to finalize files when open fails" approach. > > Well, you writing this for newspeak does not immediately benefit Squeak. > But if you point us to the code maybe someone can port it to Squeak? > I already did a year or two ago and it got shot down on the debugger grounds I reiterated above. > > - Bert - > > > > > > > -- best, Eliot

3 3

Debugging lock-ups on Windows
by Ryan Macnak 02 Sep '14

02 Sep '14

+vm-dev Hi Eliot, On Mac and Linux one can get a stack trace from a busy VM with the USR1 signal. Is there an analog on Windows? Ryan

4 6

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev September 2014