"{ Package: 'jv:calipel/s' }"

Object subclass:#BenchmarkInstance
	instanceVariableNames:'instance benchmarkSelector setUpSelector1 setUpSelector2
		tearDownSelector1 tearDownSelector2 warmUpSelector1
		warmUpSelector2'
	classVariableNames:'MillisecondsTime'
	poolDictionaries:''
	category:'CalipeL/S-Core'
!


!BenchmarkInstance class methodsFor:'instance creation'!

class:class selector:benchmark 
    ^ self new class:class selector:benchmark

    "Created: / 27-05-2013 / 19:04:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!BenchmarkInstance class methodsFor:'class initialization'!

initialize 
   "Test for Smalltalk/X"
    ((Smalltalk respondsTo: #isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
          "Use slow Smalltalk at: because Pharo does not allow to accept code with
            undefined global. Somewhat stupid!! "
        MillisecondsTime := [ (Smalltalk at: #OperatingSystem) getMillisecondTime ].
          ^self
    ].
   "Test for Squeak/Pharo"
   (Smalltalk at: #SmalltalkImage ifAbsent: [nil]) notNil ifTrue:[
        MillisecondsTime := [ Time millisecondClockValue ].
          ^self 
   ].
   self error:'Unssuported platform'

   "
   BenchmarkInstance initialize
   "

    "Created: / 31-05-2013 / 12:02:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!BenchmarkInstance methodsFor:'accessing'!

instance
    ^ instance
!

selector
    ^ benchmarkSelector
! !

!BenchmarkInstance methodsFor:'initialization'!

class:class selector:benchmark 
    self instance:class new selector:benchmark

    "Created: / 27-05-2013 / 19:04:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

instance:anObject selector:aSelector 
    | benchmarkMethod  annotation |

    (anObject respondsTo:aSelector) ifFalse:[
        self 
            error:'Object does not respond to benchmark (no ' 
                    , anObject class printString , '>>' 
                    , aSelector storeString.
    ].
    instance := anObject.
    benchmarkSelector := aSelector.
    instance class methodDictionary 
        keysAndValuesDo:[:selector :method | 
            method numArgs == 0 ifTrue:[
                (method pragmaAt:#setup) notNil ifTrue:[
                    setUpSelector1 notNil ifTrue:[
                        self error:'More than one <setup> method'.
                    ].
                    setUpSelector1 := selector.
                ].
                (method pragmaAt:#teardown) notNil ifTrue:[
                    tearDownSelector1 notNil ifTrue:[
                        self error:'More than one <teardown> method'.
                    ].
                    tearDownSelector1 := selector.
                ].
                (method pragmaAt:#warmup) notNil ifTrue:[
                    warmUpSelector1 notNil ifTrue:[
                        self error:'More than one <warmup> method'.
                    ].
                    warmUpSelector1 := selector.
                ].
            ].
        ].
    benchmarkMethod := instance class compiledMethodAt:benchmarkSelector.
    annotation := benchmarkMethod pragmaAt:#setup:.
    annotation notNil ifTrue:[
        | method  selector |

        selector := annotation argumentAt:1.
        selector isSymbol ifFalse:[
            self error:'<setup:> annotation argument not a symbol'.
        ].
        method := instance compiledMethodAt:selector ifAbsent:[ nil ].
        method isNil ifTrue:[
            self error:'<setup:> method does not exist (' , selector , ')'.
        ].
        method numArgs ~~ 0 ifTrue:[
            self error:'<setup:> method has arguments (' , selector , ')'.
        ].
        setUpSelector2 := selector.
    ].
    annotation := benchmarkMethod pragmaAt:#teardown:.
    annotation notNil ifTrue:[
        | method  selector |

        selector := annotation argumentAt:1.
        selector isSymbol ifFalse:[
            self error:'<teardown:> annotation argument not a symbol'.
        ].
        method := instance compiledMethodAt:selector ifAbsent:[ nil ].
        method isNil ifTrue:[
            self error:'<teardown:> method does not exist (' , selector , ')'.
        ].
        method numArgs ~~ 0 ifTrue:[
            self error:'<teardown:> method has arguments (' , selector , ')'.
        ].
        tearDownSelector2 := selector.
    ].
    annotation := benchmarkMethod pragmaAt:#warmup:.
    annotation notNil ifTrue:[
        | method  selector |

        selector := annotation argumentAt:1.
        selector isSymbol ifFalse:[
            self error:'<warmup:> annotation argument not a symbol'.
        ].
        method := instance compiledMethodAt:selector ifAbsent:[ nil ].
        method isNil ifTrue:[
            self error:'<warmup:> method does not exist (' , selector , ')'.
        ].
        method numArgs ~~ 0 ifTrue:[
            self error:'<warmup:> method has arguments (' , selector , ')'.
        ].
        warmUpSelector2 := selector.
    ].

    "Created: / 27-05-2013 / 19:06:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 28-05-2013 / 10:57:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!BenchmarkInstance methodsFor:'running'!

run
    ^self run: BenchmarkResult new.

    "Created: / 27-05-2013 / 19:10:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

run: aBenchmarkResult
    ^self run: aBenchmarkResult with: Dictionary new

    "Created: / 27-05-2013 / 19:10:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 28-05-2013 / 00:02:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

run: aBenchmarkResult with: aDictionary
    aBenchmarkResult runBenchmark: self withParameters: aDictionary.
    ^aBenchmarkResult

    "Created: / 27-05-2013 / 22:18:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

runBenchmarkWithParameters:aBenchmarkParameterSet 
    | t |

    t := -1.
    [
        self setUp.
        self setUpParameters:aBenchmarkParameterSet.
        self warmUp.
        t := self benchmark.
    ] ensure:[ self tearDown. ].
    ^ t

    "Created: / 27-05-2013 / 22:25:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 28-05-2013 / 08:49:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

runWith: aDictionary
    ^self run: BenchmarkResult new with: aDictionary

    "Created: / 27-05-2013 / 22:18:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!BenchmarkInstance methodsFor:'running-private'!

benchmark
    | t0  t1 |

    t0 := MillisecondsTime value.
    instance perform:benchmarkSelector.
    t1 := MillisecondsTime value.
    ^ t1 - t0

    "Created: / 28-05-2013 / 08:49:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 31-05-2013 / 12:02:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

setUp
    setUpSelector1 notNil ifTrue:[
        instance perform: setUpSelector1 
    ].
    setUpSelector2 notNil ifTrue:[
        instance perform: setUpSelector2 
    ].

    "Created: / 27-05-2013 / 19:02:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 28-05-2013 / 10:58:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

setUpParameter: name from: parameters type: type values: values
    | key1 key2  valueString value |

    key1 := instance class name , '#' , name.
    key2 := name.
    valueString := parameters at: key1 ifAbsent:[parameters at: key2 ifAbsent:[^ self]].
    (type includesBehavior: CharacterArray) ifTrue:[
        value := valueString.
    ] ifFalse:[
        value := type readFrom: valueString onError:[ self error:'Cannot read parameter '. name ,' (conversion error)'].
    ].
    values notNil ifTrue:[
        (values includes: value) ifFalse:[
            self error: 'Invalid parameter value for ', name , ' (' , value storeString ,')'
        ].
    ].
    instance perform: (name , ':') asSymbol with: value.

    "Created: / 28-05-2013 / 00:01:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

setUpParameters: aDictionary
    instance class methodDictionary keysAndValuesDo:[:selector :method |
        | annotation name type values value |
        method numArgs == 1 ifTrue:[
            (annotation := method pragmaAt: #parameter:) notNil ifTrue:[
                type := Smalltalk at: (annotation argumentAt: 1)
            ] ifFalse:[
                (annotation := method pragmaAt: #parameter:values:) notNil ifTrue:[
                    type :=  Smalltalk at: (annotation argumentAt: 1).
                    values := (annotation argumentAt: 2)
                ]
            ].
            annotation notNil ifTrue:[
                name := selector.
                name last = $: ifTrue:[
                    name := name copyWithoutLast: 1.
                ].
                self setUpParameter: name from: aDictionary type: type values: values  
            ].
        ].
    ]

    "Created: / 27-05-2013 / 22:27:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 28-05-2013 / 00:08:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

tearDown
    tearDownSelector1 notNil ifTrue:[
        instance perform: tearDownSelector1 
    ].
    tearDownSelector2 notNil ifTrue:[
        instance perform: tearDownSelector2
    ].

    "Created: / 27-05-2013 / 19:02:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 28-05-2013 / 10:58:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

warmUp
    | warmed |

    warmed := false.
    warmUpSelector1 notNil ifTrue:[
        instance perform: warmUpSelector1.
        warmed := true.
    ].
    warmUpSelector2 notNil ifTrue:[
        instance perform: warmUpSelector2.
        warmed := true.
    ].
    "Default warmup"
    warmed ifFalse:[
        instance perform: benchmarkSelector 
    ].
    ObjectMemory garbageCollect; tenure.

    "Created: / 27-05-2013 / 19:02:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 04-06-2013 / 22:19:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!BenchmarkInstance class methodsFor:'documentation'!

version_HG

    ^ '$Changeset: <not expanded> $'
!

version_MC
    ^ 'CalipeL_S-Core-JanVrany.7 5c300a20-c9d7-11e2-a959-606720e43e2c 2013-05-31T10:49:17 JanVrany'
! !


BenchmarkInstance initialize!