Merge cmf cmf callgraph and develop

packages/Babylonian-Compiler.package/BPCompiler.class/instance/compile.ifFail..st

@@ -1,20 +1,4 @@
 public access
 compile: aCueWithBPSource ifFail: failBlock
 
-	"This method expects source code which has annotations embedded in comments, if any."
-	| originalMethodNode bpSource basicCue |
-	bpSource := aCueWithBPSource sourceStream contents asString.
-	basicCue := CompilationCue
-		source: bpSource readStream
-		context: aCueWithBPSource context 
-		receiver: aCueWithBPSource receiver 
-		class: aCueWithBPSource getClass 
-		environment: aCueWithBPSource environment 
-		requestor: aCueWithBPSource requestor.
-	originalMethodNode := super compile: basicCue ifFail: failBlock.
-	self haltOnce.
-	bpSource := originalMethodNode sourceText asString.
-	(self methodSourceRequiresBPLayers: bpSource) ifTrue: [
-		(self compileInstrumentedVersionOf: aCueWithBPSource) ifFalse: failBlock].
-
-	^ originalMethodNode
+	^ self compileCue: aCueWithBPSource noPattern: false ifFail: failBlock

packages/Babylonian-Compiler.package/BPCompiler.class/instance/compileCue.noPattern.ifFail..st

@@ -0,0 +1,24 @@
+public access
+compileCue: aCueWithBPSource noPattern: aBoolean ifFail: failBlock
+
+
+	"This method expects source code which has annotations embedded in comments, if any."
+	| originalMethodNode bpSource basicCue |
+
+	aBoolean ifTrue: [self error: 'Cannot use BPCompiler for methods without patterns.'].
+
+	bpSource := aCueWithBPSource sourceStream contents asString.
+	basicCue := CompilationCue
+		source: bpSource readStream
+		context: aCueWithBPSource context 
+		receiver: aCueWithBPSource receiver 
+		class: aCueWithBPSource getClass 
+		environment: aCueWithBPSource environment 
+		requestor: aCueWithBPSource requestor.
+	originalMethodNode := super compileCue: basicCue noPattern: aBoolean ifFail: failBlock.
+
+	bpSource := originalMethodNode sourceText asString.
+	(self methodSourceRequiresBPLayers: bpSource) ifTrue: [
+		(self compileInstrumentedVersionOf: aCueWithBPSource) ifFalse: failBlock].
+
+	^ originalMethodNode

packages/Babylonian-Compiler.package/BPCompiler.class/methodProperties.json

@@ -1,13 +1,14 @@
 {
 	"class" : {
-		"bpInstrumentedLayerName" : "pre 11/25/2020 11:41",
-		"compilerClass" : "pre 11/25/2020 11:17",
+		"bpInstrumentedLayerName" : " 1/15/2021 09:22:32",
+		"compilerClass" : "cmfcmf 10/30/2020 12:39",
 		"exampleTextAnchor" : "pre 11/8/2019 12:05" },
 	"instance" : {
 		"annotationKeywords" : "pre 11/8/2019 20:29",
-		"backgroundCompileInstrumentedVersionOf:basedOn:" : "pre 10/12/2020 15:36",
-		"compile:ifFail:" : "pre 10/12/2020 15:28",
-		"compileInstrumentedVersionOf:" : "pre 1/11/2021 15:51",
+		"backgroundCompileInstrumentedVersionOf:basedOn:" : "pre 8/20/2020 15:46",
+		"compile:ifFail:" : "cmfcmf 10/27/2020 11:15",
+		"compileCue:noPattern:ifFail:" : "cmfcmf 10/30/2020 12:39",
+		"compileInstrumentedVersionOf:" : "pre 8/17/2020 08:58",
 		"keywords" : "pre 7/26/2019 14:00",
 		"methodSourceRequiresBPLayers:" : "pre 11/11/2019 15:49",
 		"parse:" : "pre 1/11/2021 15:51",

packages/Babylonian-Core.package/BPByteCodeAssociation.class/README.md

@@ -0,0 +1 @@
+I am an association that is considered equal in the context of a literal if my key as well as my value is equal to another instance of myself.

packages/Babylonian-Core.package/BPByteCodeAssociation.class/instance/literalEqual..st

@@ -0,0 +1,4 @@
+literals
+literalEqual: other
+
+	^ self class == other class and: [self key == other key] and: [self value == other value]

packages/Babylonian-Core.package/BPByteCodeAssociation.class/methodProperties.json

@@ -0,0 +1,5 @@
+{
+	"class" : {
+		 },
+	"instance" : {
+		"literalEqual:" : "cmfcmf 10/22/2020 12:59" } }

packages/Babylonian-Core.package/BPByteCodeAssociation.class/properties.json

@@ -0,0 +1,14 @@
+{
+	"category" : "Babylonian-Core-Callgraph-ByteCode",
+	"classinstvars" : [
+		 ],
+	"classvars" : [
+		 ],
+	"commentStamp" : "cmfcmf 10/20/2020 12:33",
+	"instvars" : [
+		 ],
+	"name" : "BPByteCodeAssociation",
+	"pools" : [
+		 ],
+	"super" : "Association",
+	"type" : "normal" }

packages/Babylonian-Core.package/BPByteCodeCallgraphTracer.class/class/customEvent.data..st

@@ -0,0 +1,5 @@
+tracing
+customEvent: aSymbol data: anObject
+
+
+	self value ifNotNil: [:t | t customEvent: aSymbol data: anObject]

packages/Babylonian-Core.package/BPByteCodeCallgraphTracer.class/class/deactivateDuring..st

@@ -0,0 +1,4 @@
+process local
+deactivateDuring: aBlock
+
+	^ self value: nil during: aBlock

packages/Babylonian-Core.package/BPByteCodeCallgraphTracer.class/class/enter.invocation..st

@@ -0,0 +1,5 @@
+tracing
+enter: aString invocation: aNumber
+
+
+	self value ifNotNil: [:t | t enter: aString invocation: aNumber]

packages/Babylonian-Core.package/BPByteCodeCallgraphTracer.class/class/exit.invocation.returns..st

@@ -0,0 +1,5 @@
+tracing
+exit: aString invocation: aNumber returns: aBoolean
+
+
+	self value ifNotNil: [:t | t exit: aString invocation: aNumber returns: aBoolean]

packages/Babylonian-Core.package/BPByteCodeCallgraphTracer.class/class/swapSenderOf.newSender..st

@@ -0,0 +1,5 @@
+tracing
+swapSenderOf: context newSender: newSender
+
+
+	self value ifNotNil: [:t | self value: nil during: [t swapSenderOf: context newSender: newSender]]

packages/Babylonian-Core.package/BPByteCodeCallgraphTracer.class/class/value.during..st

@@ -0,0 +1,4 @@
+process local
+value: anObject during: aBlock
+
+	^ self value: anObject during: aBlock inProcess: Processor activeProcess

packages/Babylonian-Core.package/BPByteCodeCallgraphTracer.class/class/value.during.inProcess..st

@@ -0,0 +1,7 @@
+process local
+value: anObject during: aBlock inProcess: aProcess
+
+	| old |
+	old := aProcess tracer.
+	aProcess tracer: anObject.
+	^ aBlock ensure: [aProcess tracer: old]

packages/Babylonian-Core.package/BPByteCodeCallgraphTracer.class/class/value.st

@@ -0,0 +1,4 @@
+process local
+value
+
+	^ Processor activeProcess tracer

packages/Babylonian-Core.package/BPByteCodeCallgraphTracer.class/instance/blockIdxFromContext..st

@@ -0,0 +1,11 @@
+private
+blockIdxFromContext: aContext
+
+	| pc state blockPositions blockIdx |
+	self assert: aContext isClosureContext.
+	pc := aContext closure blockCreationPC.
+	state := BPByteCodeMethodState ofMethod: aContext method.
+	blockPositions := state nopPositions select: [:each | each first == #beforeBlock] thenCollect: [:each | each second stop + 1].
+	blockIdx := blockPositions indexOf: pc.
+	self assert: blockIdx > 0.
+	^ blockIdx + 1

packages/Babylonian-Core.package/BPByteCodeCallgraphTracer.class/instance/customEvent.data..st

@@ -0,0 +1,7 @@
+tracing
+customEvent: aSymbol data: anObject
+
+
+	events nextPut: #custom.
+	events nextPut: aSymbol.
+	events nextPut: anObject

packages/Babylonian-Core.package/BPByteCodeCallgraphTracer.class/instance/enter.invocation..st

@@ -0,0 +1,10 @@
+tracing
+enter: aString invocation: aNumber
+
+	| senderContext |
+	events nextPut: #enter.
+	events nextPut: aString.
+	events nextPut: aNumber.
+	senderContext := thisContext sender sender sender.
+	events nextPut: senderContext pc.
+	events nextPut: senderContext method.

packages/Babylonian-Core.package/BPByteCodeCallgraphTracer.class/instance/eventStream.st

@@ -0,0 +1,4 @@
+accessing
+eventStream
+
+	^ events readStream 

packages/Babylonian-Core.package/BPByteCodeCallgraphTracer.class/instance/eventsForTree.st

@@ -0,0 +1,120 @@
+post processing
+eventsForTree
+
+	| callgraph depth depthAfterExit depthMap printContinuesHere eventStream treeCache addToTree prevDepth overwriteDepth executionContinuation senderMethod |
+
+	depth := 0.
+	depthAfterExit := nil.
+
+	depthMap := Dictionary new.
+
+	callgraph := BPCallgraph new.
+	treeCache := Dictionary new.
+	prevDepth := -1.
+	overwriteDepth := -1.
+	addToTree := [:entry | | theDepth |
+		theDepth := overwriteDepth >= 0 ifTrue: [overwriteDepth] ifFalse: [depth].
+		theDepth > (prevDepth + 1) ifTrue: [
+			"context jumped to the right by more than 1 step, therefore we need to add 
+			new tree nodes (->) to correctly mount the following nodes"
+			self assert: theDepth - executionContinuation second size >= 0.
+
+			executionContinuation second withIndexDo: [:helper :i |
+				overwriteDepth := theDepth - 1 - (executionContinuation second size - i).
+				addToTree value: helper].
+			"(theDepth - 1 - executionContinuation second size) to: theDepth - 1 do: [:i | 
+				overwriteDepth := i.
+				addToTree value: BPCallgraphEntryContextJumpHelper new]."
+			overwriteDepth := -1].
+
+		theDepth == 0
+			ifTrue: [callgraph addRoot: entry]
+			ifFalse: [(treeCache at: theDepth - 1) addChild: entry].
+		treeCache at: theDepth put: entry.
+		prevDepth := theDepth].
+
+	printContinuesHere := [| entry |
+		addToTree value: executionContinuation first.
+		executionContinuation := nil].
+
+	eventStream := self eventStream.
+	[eventStream atEnd] whileFalse: [| entry | eventStream next caseOf: {
+		[#enter] -> [ | parts class selector blockIdx invocationCount senderPC |			
+			parts := eventStream next splitBy: ' >> '.
+			class := parts first.
+			selector := parts second.
+			blockIdx := parts third asInteger.
+			"invocation count of the surrounding method. In other words: 'Id' of the context of this block/method, unique per method"
+			invocationCount := eventStream next.
+			senderPC := eventStream next.
+			senderMethod := eventStream next.
+
+			entry := BPCallgraphEntryEnter new.
+			entry class: class selector: selector blockIdx: blockIdx invocationCount: invocationCount senderPC: senderPC senderMethod: senderMethod.
+			addToTree value: entry.
+
+			blockIdx == 1 ifTrue: [depthMap at: {class . selector . invocationCount} put: depth].
+			depth := depth + 1].
+		[#exit] -> [ | parts class selector blockIdx invocationCount blockReturns |
+			parts := eventStream next splitBy: ' >> '.
+			class := parts first.
+			selector := parts second.
+			blockIdx := parts third asInteger.
+			"invocation count of the surrounding method. In other words: 'Id' of the context of this block/method, unique per method"
+			invocationCount := eventStream next.
+			blockReturns := eventStream next.
+
+			depth := depth - 1.
+			self assert: depth >= 0.
+
+			entry := BPCallgraphEntryExit new.
+			entry class: class selector: selector blockIdx: blockIdx invocationCount: invocationCount returns: blockReturns.
+			addToTree value: entry.
+
+			blockReturns ifTrue: [| oldDepth |
+				oldDepth := depthMap removeKey: {class . selector . invocationCount}.
+				blockIdx > 1 ifTrue: [depth := oldDepth]].
+
+			depthAfterExit ifNotNil: [
+				depth := depthAfterExit.
+				depthAfterExit := nil.
+				printContinuesHere value]].
+		[#contextSenderChanged] -> [ | depthDelta inChainOrNumMoveRight inChain hasActiveTracing executionContinuationEntry |
+			depthDelta := eventStream next.
+			inChainOrNumMoveRight := eventStream next.
+			inChain := inChainOrNumMoveRight == true.
+			hasActiveTracing := eventStream next.
+
+			"ignore events when depth didn't change and method that causes the change does not have active tracing."
+			(depthDelta ~= 0 or: hasActiveTracing) ifTrue: [
+				hasActiveTracing 
+					ifTrue: [
+						depthAfterExit := depth + depthDelta.
+						"depth := depth + 1"]
+					ifFalse: [depth := depth + depthDelta].
+				self assert: depth >= 0.
+
+				executionContinuationEntry := BPCallgraphEntryContextExecutionContinuation new.
+				executionContinuation := {executionContinuationEntry . inChainOrNumMoveRight}.
+				entry := BPCallgraphEntryContextSenderChanged new.
+				entry 
+					depthDelta: depthDelta 
+					inChain: inChain 
+					hasActiveTracing: hasActiveTracing 
+					executionContinuationEntry: executionContinuationEntry.
+				addToTree value: entry.
+
+				hasActiveTracing ifFalse: [printContinuesHere value]]].
+		[#custom] -> [| type data |
+			type := eventStream next.
+			data := eventStream next.
+
+			entry := (type caseOf: {
+				[#bpProbeHit] -> [BPCallgraphEntryBPProbe].
+				[#bpAssertionHit] -> [BPCallgraphEntryBPAssertion].
+				[#bpExample] -> [BPCallgraphEntryBPExample]}otherwise: [BPCallgraphEntryCustomEvent]) new.
+			entry type: type data: data.
+			addToTree value: entry]
+	}].
+
+	^ callgraph