amber/st/Compiler-Interpreter.st

Smalltalk current createPackage: 'Compiler-Interpreter'!
BlockClosure subclass: #AIBlockClosure
	instanceVariableNames: 'node outerContext'
	package: 'Compiler-Interpreter'!
!AIBlockClosure commentStamp!
I am a special `BlockClosure` subclass used by an interpreter to interpret a block node.

While I am polymorphic with `BlockClosure`, some methods such as `#new` will raise interpretation errors. Unlike a `BlockClosure`, my instance are not JavaScript functions.

Evaluating an instance will result in interpreting the `node` instance variable (instance of `BlockNode`).!

!AIBlockClosure methodsFor: 'accessing'!

compiledSource
	"Unlike blocks, the receiver doesn't represent a JS function"
	
	^ '[ AST Block closure ]'
!

numArgs
	^ node temps size
! !

!AIBlockClosure methodsFor: 'converting'!

currySelf
	self interpreterError
! !

!AIBlockClosure methodsFor: 'error handling'!

interpreterError
	AIInterpreterError signal: 'Method cannot be interpreted by the interpreter.'
! !

!AIBlockClosure methodsFor: 'evaluating'!

applyTo: anObject arguments: aCollection
	self interpreterError
!

value
	^ self valueWithPossibleArguments: #()
!

value: anArgument
	^ self valueWithPossibleArguments: {anArgument}
!

value: firstArgument value: secondArgument
	^ self valueWithPossibleArguments: {firstArgument . secondArgument}
!

value: firstArgument value: secondArgument value: thirdArgument
	^ self valueWithPossibleArguments: {firstArgument . secondArgument . thirdArgument}
!

valueWithPossibleArguments: aCollection
	| context sequenceNode |
	context := outerContext newBlockContext.

	"Interpret a copy of the sequence node to avoid creating a new AIBlockClosure"
	sequenceNode := node nodes first copy
		parent: nil;
		yourself.

	"Populate the arguments into the context locals"	
	node parameters withIndexDo: [ :each :index |
		context localAt: each put: (aCollection at: index ifAbsent: [ nil ]) ].

	"Interpret the first node of the BlockSequenceNode"
	context interpreter
		node: sequenceNode nextChild;
		proceed.
		
	outerContext interpreter
		setNonLocalReturnFromContext: context.
		
	^ context interpreter pop
! !

!AIBlockClosure methodsFor: 'initialization'!

initializeWithContext: aContext node: aNode
	node := aNode.
	outerContext := aContext
! !

!AIBlockClosure class methodsFor: 'instance creation'!

forContext: aContext node: aNode
	^ self new
		initializeWithContext: aContext node: aNode;
		yourself
! !

Object subclass: #AIContext
	instanceVariableNames: 'outerContext innerContext pc locals method index ast interpreter'
	package: 'Compiler-Interpreter'!
!AIContext commentStamp!
I am like a `MethodContext`, used by the `ASTInterpreter`.
Unlike a `MethodContext`, my instances are not read-only.

When debugging, my instances are created by copying the current `MethodContext` (thisContext)!

!AIContext methodsFor: 'accessing'!

index
	^ index ifNil: [ 0 ]
!

index: anInteger
	index := anInteger
!

innerContext
	^ innerContext
!

innerContext: anAIContext
	innerContext := anAIContext
!

localAt: aString
	"Lookup the local value up to the method context"

	^ self locals at: aString ifAbsent: [ 
		self isBlockContext 
			ifTrue: [ nil ]
			ifFalse: [ self outerContext localAt: aString ] ]
!

localAt: aString put: anObject
	self locals at: aString put: anObject
!

locals
	locals ifNil: [ self initializeLocals ].
	
	^ locals
!

method
	^ method
!

method: aCompiledMethod
	method := aCompiledMethod
!

methodContext
	self isBlockContext ifFalse: [ ^ self ].
	
	^ self outerContext ifNotNil: [ :outer |
		outer methodContext ]
!

outerContext
	^ outerContext
!

outerContext: anAIContext
	outerContext := anAIContext.
	outerContext innerContext: self
!

selector
	^ self method ifNotNil: [ 
		self method selector ]
! !

!AIContext methodsFor: 'converting'!

asString
	^self isBlockContext
		ifTrue: [ 'a block (in ', self methodContext asString, ')' ]
		ifFalse: [ self receiver class name, ' >> ', self selector ]
! !

!AIContext methodsFor: 'factory'!

newBlockContext
	^ self class new
		outerContext: self;
		yourself
! !

!AIContext methodsFor: 'initialization'!

initializeAST
	ast := self method ast.
	(SemanticAnalyzer on: self method methodClass)
		visit: ast
!

initializeFromMethodContext: aMethodContext

	self 
		pc: aMethodContext pc;
		index: aMethodContext index;
		receiver: aMethodContext receiver;
		method: aMethodContext method.
		
	aMethodContext outerContext ifNotNil: [ :outer |
		"If the method context is nil, the block was defined in JS, so ignore it"
		outer methodContext ifNotNil: [
			self outerContext: (self class fromMethodContext: aMethodContext outerContext) ].
			aMethodContext locals keysAndValuesDo: [ :key :value |
				self locals at: key put: value ] ]
!

initializeInterpreter
	interpreter := ASTInterpreter new
		context: self;
		yourself.
	ast ifNotNil: [ interpreter node: self retrieveNode ].
	
	(self innerContext notNil and: [ 
		self innerContext isBlockContext not ]) ifTrue: [
			self setupInterpreter: interpreter ]
!

initializeLocals
	locals := Dictionary new.
	locals at: 'thisContext' put: self.
! !

!AIContext methodsFor: 'interpreting'!

arguments
	^ self ast arguments collect: [ :each |
		self localAt: each ]
!

ast
	self isBlockContext ifTrue: [ ^ self outerContext ast ].

	ast ifNil: [ self initializeAST ].
	^ ast
!

interpreter
	interpreter ifNil: [ self initializeInterpreter ].
	^ interpreter
!

interpreter: anInterpreter
	interpreter := anInterpreter
!

pc
	^ pc ifNil: [ pc := 0 ]
!

pc: anInteger
	pc := anInteger
!

receiver
	^ self localAt: 'self'
!

receiver: anObject
	self localAt: 'self' put: anObject
!

retrieveNode
	^ ASTPCNodeVisitor new
		context: self;
		visit: self ast;
		currentNode
!

setupInterpreter: anInterpreter
	"Push the send args and receiver to the interpreter stack"
	
	self innerContext arguments reversed do: [ :each | 
		anInterpreter push: each ].
		
	anInterpreter push: (self innerContext receiver)
! !

!AIContext methodsFor: 'testing'!

isBlockContext
	"Block context do not have selectors."
	
	^ self selector isNil
! !

!AIContext class methodsFor: 'instance creation'!

fromMethodContext: aMethodContext
	^ self new
		initializeFromMethodContext: aMethodContext;
		yourself
! !

Error subclass: #AIInterpreterError
	instanceVariableNames: ''
	package: 'Compiler-Interpreter'!
!AIInterpreterError commentStamp!
I get signaled when an AST interpreter is unable to interpret a node.!

Object subclass: #ASTDebugger
	instanceVariableNames: 'interpreter context'
	package: 'Compiler-Interpreter'!
!ASTDebugger commentStamp!
I am a stepping debugger interface for Amber code.
I internally use an instance of `ASTSteppingInterpreter` to actually step through node and interpret them.

My instances are created from a `MethodContext` with `ASTDebugger class >> context:`.
They hold an `AIContext` instance internally, recursive copy of the `MethodContext`.

## API

Use the methods of the `'stepping'` protocol to do stepping.!

!ASTDebugger methodsFor: 'accessing'!

context
	^ context
!

context: aContext
	context := aContext
!

interpreter
	^ interpreter ifNil: [ interpreter := self defaultInterpreterClass new ]
!

interpreter: anInterpreter
	interpreter := anInterpreter
!

method
	^ self context method
!

nextNode
	^ self interpreter nextNode
! !

!ASTDebugger methodsFor: 'defaults'!

defaultInterpreterClass
	^ ASTSteppingInterpreter
! !

!ASTDebugger methodsFor: 'initialization'!

buildAST
	"Build the AST tree from the method source code.
	The AST is annotated with a SemanticAnalyzer,
	to know the semantics and bindings of each node needed for later debugging"
	
	| ast |
	
	ast := Smalltalk current parse: self method source.
	(SemanticAnalyzer on: self context receiver class)
		visit: ast.
	
	^ ast
!

initializeInterpreter
	| ast next |
	ast := self buildAST.
	next := ASTPCNodeVisitor new
		context: self context;
		visit: ast;
		currentNode.
	self interpreter interpret: next
!

initializeWithContext: aContext
	"TODO: do we need to handle block contexts?"
	
	self context: aContext.
	self initializeInterpreter
! !

!ASTDebugger methodsFor: 'stepping'!

proceed
	self shouldBeImplemented
!

restart
	self shouldBeImplemented
!

step
	"The ASTSteppingInterpreter stops at each node interpretation.
	One step will interpret nodes until:
	- we get at the end
	- the next node is a stepping node (send, assignment, etc.)"
	
	[ (self interpreter nextNode notNil and: [ self interpreter nextNode stopOnStepping ])
		or: [ self interpreter atEnd not ] ]
			whileFalse: [
				self interpreter step.
				self step ]
!

stepInto
	self shouldBeImplemented
!

stepOver
	self step
! !

!ASTDebugger methodsFor: 'testing'!

atEnd
	^ self interpreter atEnd
! !

!ASTDebugger class methodsFor: 'instance creation'!

context: aContext
	^ self new
		initializeWithContext: aContext;
		yourself
! !

NodeVisitor subclass: #ASTInterpreter
	instanceVariableNames: 'node context stack returnValue returned'
	package: 'Compiler-Interpreter'!

!ASTInterpreter methodsFor: 'accessing'!

context
	^ context
!

context: aContext
	context := aContext
!

node
	"Answer the next node, ie the node to be evaluated in the next step"
	
	^ node
!

node: aNode
	node := aNode
!

result
	^ self hasReturned 
		ifTrue: [ self returnValue ] 
		ifFalse: [ self context receiver ]
!

returnValue
	^ returnValue
!

returnValue: anObject
	returnValue := anObject
!

stack
	^ stack ifNil: [ stack := OrderedCollection new ]
! !

!ASTInterpreter methodsFor: 'interpreting'!

interpret
	"Interpret the next node to be evaluated"
	
	self visit: self node
!

interpret: aNode
	self node: aNode.
	self interpret
!

next
	self node: self node nextNode
!

proceed
	"Eagerly evaluate the ast"
	
	[ self atEnd ] whileFalse: [ 
		self step ]
!

restart
	self node: self context ast nextChild
!

setNonLocalReturnFromContext: aContext
	aContext interpreter hasReturned ifTrue: [
		returned := true.
		self returnValue: aContext interpreter returnValue ]
!

skip
	self next
!

step
	self 
		interpret; 
		next
!

stepOver
	self step.
	
	[ self node isSteppingNode ] whileFalse: [ 
		self step ]
! !

!ASTInterpreter methodsFor: 'private'!

assign: aNode to: anObject
	aNode binding isInstanceVar
		ifTrue: [ self context receiver instVarAt: aNode value put: anObject ]
		ifFalse: [ self context localAt: aNode value put: anObject ]
!

eval: aString
	"Evaluate aString as JS source inside an JS function.
	aString is not sandboxed."
	
	| source function |
	
	source := String streamContents: [ :str |
		str nextPutAll: '(function('.
		self context locals keys
			do: [ :each | str nextPutAll: each ]
			separatedBy: [ str nextPutAll: ',' ].
		str
			nextPutAll: '){ return (function() {';
			nextPutAll: aString;
			nextPutAll: '})() })' ].
			
	function := Compiler new eval: source.
	
	^ function valueWithPossibleArguments: self context locals values
!

messageFromSendNode: aSendNode arguments: aCollection
	^ Message new
		selector: aSendNode selector;
		arguments: aCollection;
		yourself
!

messageNotUnderstood: aMessage receiver: anObject
	MessageNotUnderstood new
		meesage: aMessage;
		receiver: anObject;
		signal
!

sendMessage: aMessage to: anObject superSend: aBoolean
	| method |
	
	aBoolean ifFalse: [ ^ aMessage sendTo: anObject ].
	anObject class superclass ifNil: [ ^ self messageNotUnderstood: aMessage receiver: anObject ].
	
	method := anObject class superclass methodDictionary
		at: aMessage selector
		ifAbsent: [ ^ self messageNotUnderstood: aMessage receiver: anObject ].
		
	^ method sendTo: anObject arguments: aMessage arguments
! !

!ASTInterpreter methodsFor: 'stack'!

peek
	"Peek the top object of the context stack"
	
	self stack ifEmpty: [ ^ nil ].
	
	^ self stack last
!

pop
	"Pop an object from the context stack"
	
	| peekedValue |
	
	peekedValue := self peek.
	self stack removeLast.
	^ peekedValue
!

push: anObject
	"Push an object to the context stack"
	
	^ self stack add: anObject
! !

!ASTInterpreter methodsFor: 'testing'!

atEnd
	^ self hasReturned or: [ self node isNil ]
!

hasReturned
	^ returned ifNil: [ false ]
! !

!ASTInterpreter methodsFor: 'visiting'!

visit: aNode
	self hasReturned ifFalse: [ super visit: aNode ]
!

visitAssignmentNode: aNode
	| poppedValue |
	
	poppedValue := self pop.
	
	"Pop the left side of the assignment.
	It already has been visited, and we don't need its value."
	self pop.
	
	self push: poppedValue.
	self assign: aNode left to: poppedValue
!

visitBlockNode: aNode
	"Do not evaluate the block node.
	Instead, put all instructions into a block that we push to the stack for later evaluation"
	
	| block |
	
	block := AIBlockClosure forContext: self context node: aNode.
	
	self push: block
!

visitClassReferenceNode: aNode
	self push: (Smalltalk current 
		at: aNode value 
		ifAbsent: [ PlatformInterface globals at: aNode value ])
!

visitDynamicArrayNode: aNode
	| array |
	
	array := #().
	aNode nodes do: [ :each |
		array addFirst: self pop ].
	
	self push: array
!

visitDynamicDictionaryNode: aNode
	| hashedCollection |
	
	hashedCollection := HashedCollection new.
	aNode nodes do: [ :each | 
		hashedCollection add: self pop ].
	
	self push: hashedCollection
!

visitJSStatementNode: aNode
	returned := true.
	self returnValue: (self eval: aNode source)
!

visitNode: aNode
	"Do nothing by default. Especially, do not visit children recursively."
!

visitReturnNode: aNode
	returned := true.
	self returnValue: self pop
!

visitSendNode: aNode
	| receiver args message result |
	
	args := aNode arguments collect: [ :each | self pop ].
	receiver := self pop.
	
	message := self
		messageFromSendNode: aNode
		arguments: args reversed.
	
	result := self sendMessage: message to: receiver superSend: aNode superSend.
	
	self context pc: self context pc + 1.
	
	"For cascade sends, push the reciever if the send is not the last one"
	(aNode isCascadeSendNode and: [ aNode isLastChild not ])
		ifTrue: [ self push: receiver ]
		ifFalse: [ self push: result ]
!

visitValueNode: aNode
	self push: aNode value
!

visitVariableNode: aNode
	aNode binding isUnknownVar ifTrue: [
		^ self push: (PlatformInterface globals at: aNode value ifAbsent: [ self error: 'Unknown variable' ]) ].
		
	self push: (aNode binding isInstanceVar
		ifTrue: [ self context receiver instVarAt: aNode value ]
		ifFalse: [ self context localAt: aNode value ])
! !

NodeVisitor subclass: #ASTPCNodeVisitor
	instanceVariableNames: 'useInlinings pc context blockIndex currentNode'
	package: 'Compiler-Interpreter'!
!ASTPCNodeVisitor commentStamp!
I visit an AST until I get to the current pc node and answer it.

## API

My instances must be filled with a context object using `#context:`.

After visiting the AST the current node corresponding to the `pc` is answered by `#currentNode`!

!ASTPCNodeVisitor methodsFor: 'accessing'!

blockIndex
	^ blockIndex ifNil: [ blockIndex := 0 ]
!

context
	^ context
!

context: aContext
	context := aContext
!

currentNode
	^ currentNode
!

increaseBlockIndex
	blockIndex := self blockIndex + 1
!

pc
	^ pc ifNil: [ 0 ]
!

pc: anInteger
	pc := anInteger
!

useInlinings
	^ useInlinings ifNil: [ true ]
!

useInlinings: aBoolean
	useInlinings := aBoolean
! !

!ASTPCNodeVisitor methodsFor: 'visiting'!

visitBlockNode: aNode
	"Inlined send node. Assume that the block is inlined"
	(aNode parent isSendNode and: [ aNode parent shouldBeInlined ])
		ifFalse: [
			self blockIndex >= self context index ifFalse: [
				self increaseBlockIndex.
				super visitBlockNode: aNode ] ]
		ifTrue: [ super visitBlockNode: aNode ]
!

visitJSStatementNode: aNode
	currentNode := aNode
!

visitSendNode: aNode
	super visitSendNode: aNode.
	
	self pc = self context pc ifFalse: [
		aNode shouldBeInlined ifFalse: [
			self blockIndex = self context index ifTrue: [
				self pc: self pc + 1.
				currentNode := aNode ] ] ]
! !

!Node methodsFor: '*Compiler-Interpreter'!

interpreter: anInterpreter continue: aBlock
	^ anInterpreter interpretNode: self continue: aBlock
!

isSteppingNode
	^ false
! !

!AssignmentNode methodsFor: '*Compiler-Interpreter'!

interpreter: anInterpreter continue: aBlock
	^ anInterpreter interpretAssignmentNode: self continue: aBlock
!

isSteppingNode
	^ true
! !

!BlockNode methodsFor: '*Compiler-Interpreter'!

interpreter: anInterpreter continue: aBlock
	^ anInterpreter interpretBlockNode: self continue: aBlock
!

isSteppingNode
	^ true
! !

!CascadeNode methodsFor: '*Compiler-Interpreter'!

interpreter: anInterpreter continue: aBlock
	^ anInterpreter interpretCascadeNode: self continue: aBlock
! !

!DynamicArrayNode methodsFor: '*Compiler-Interpreter'!

interpreter: anInterpreter continue: aBlock
	^ anInterpreter interpretDynamicArrayNode: self continue: aBlock
!

isSteppingNode
	^ true
! !

!DynamicDictionaryNode methodsFor: '*Compiler-Interpreter'!

interpreter: anInterpreter continue: aBlock
	^ anInterpreter interpretDynamicDictionaryNode: self continue: aBlock
!

isSteppingNode
	^ true
! !

!JSStatementNode methodsFor: '*Compiler-Interpreter'!

interpreter: anInterpreter continue: aBlock
	^ anInterpreter interpretJSStatementNode: self continue: aBlock
!

isSteppingNode
	^ true
! !

!MethodNode methodsFor: '*Compiler-Interpreter'!

interpreter: anInterpreter continue: aBlock
	^ anInterpreter interpretMethodNode: self continue: aBlock
! !

!ReturnNode methodsFor: '*Compiler-Interpreter'!

interpreter: anInterpreter continue: aBlock
	^ anInterpreter interpretReturnNode: self continue: aBlock
! !

!SendNode methodsFor: '*Compiler-Interpreter'!

interpreter: anInterpreter continue: aBlock
	^ anInterpreter interpretSendNode: self continue: aBlock
!

isSteppingNode
	^ true
! !

!SequenceNode methodsFor: '*Compiler-Interpreter'!

interpreter: anInterpreter continue: aBlock
	^ anInterpreter interpretSequenceNode: self continue: aBlock
! !

!BlockSequenceNode methodsFor: '*Compiler-Interpreter'!

interpreter: anInterpreter continue: aBlock
	^ anInterpreter interpretBlockSequenceNode: self continue: aBlock
! !

!ValueNode methodsFor: '*Compiler-Interpreter'!

interpreter: anInterpreter continue: aBlock
	^ anInterpreter interpretValueNode: self continue: aBlock
! !

!VariableNode methodsFor: '*Compiler-Interpreter'!

interpreter: anInterpreter continue: aBlock
	^ anInterpreter interpretVariableNode: self continue: aBlock
! !

!ClassReferenceNode methodsFor: '*Compiler-Interpreter'!

interpreter: anInterpreter continue: aBlock
	^ anInterpreter interpretClassReferenceNode: self continue: aBlock
! !