amber/st/Compiler-IR.st

Smalltalk current createPackage: 'Compiler-IR' properties: #{}!
NodeVisitor subclass: #IRASTTranslator
	instanceVariableNames: 'builder source theClass'
	package: 'Compiler-IR'!
!IRASTTranslator commentStamp!
I am the AST (abstract syntax tree) visitor responsible for building the intermediate representation graph.
I rely on a builder object, instance of IRBuilder.!

!IRASTTranslator methodsFor: 'accessing'!

builder
	^ builder ifNil: [ builder := IRBuilder new ]
!

builder: aBuilder
	builder := aBuilder
!

source
	^ source
!

source: aString
	source := aString
!

theClass
	^ theClass
!

theClass: aClass
	theClass := aClass
! !

!IRASTTranslator methodsFor: 'visiting'!

visitAssignmentNode: aNode
	self builder assignment 
		with: [ self visit: aNode left ];
		with: [ self visit: aNode right ]
!

visitBlockNode: aNode
	self builder closure 
		with: [ 
			aNode scope temps do: [ :each |
				self builder tempDeclaration name: each name ].
			super visitBlockNode: aNode ];
		arguments: aNode parameters
!

visitBlockSequenceNode: aNode
	self builder blockSequence with: [
		aNode nodes do: [ :each | self visit: each ]]
!

visitJSStatementNode: aNode
	self builder verbatim: aNode source
!

visitMethodNode: aNode
	self builder method 
		source: self source;
		arguments: aNode arguments;
		selector: aNode selector;
		messageSends: aNode messageSends;
		classReferences: aNode classReferences.

	aNode scope temps do: [ :each |
		self builder tempDeclaration name: each name ].
	aNode hasNonLocalReturn 
		ifTrue: [ self builder nonLocalReturnHandling with: [
			super visitMethodNode: aNode ]]
		ifFalse: [ super visitMethodNode: aNode ].

	aNode hasLocalReturn ifFalse: [
		self builder return with: [
			self builder variable: (aNode scope pseudoVars at: 'self') ]]
!

visitReturnNode: aNode
	(aNode nonLocalReturn 
		ifTrue: [ self builder nonLocalReturn ]
		ifFalse: [ self builder return ]) with: [ super visitReturnNode: aNode ]
!

visitSendNode: aNode
	| send |
	send := self builder send.
	send selector: aNode selector.
	aNode superSend ifTrue: [ send classSend: self theClass superclass ].
	send with: [
		self visit: aNode receiver.
		(aNode arguments do: [ :each | self visit: each ]) ]
!

visitSequenceNode: aNode
	self builder sequence with: [
		super visitSequenceNode: aNode ]
!

visitValueNode: aNode
	self builder value: aNode value
!

visitVariableNode: aNode
	self builder variable: aNode binding
! !

IRASTTranslator subclass: #IRASTResolver
	instanceVariableNames: 'nextAlias'
	package: 'Compiler-IR'!
!IRASTResolver commentStamp!
I resolve nodes by creating an alias variable when appropriate, to flatten the AST.
Nodes referenced in other nodes are aliased, except for some specific nodes such as variable or value nodes.!

!IRASTResolver methodsFor: 'accessing'!

nextAlias
	"Message sends are assigned, or 'aliased', to internal variables.
	Internal variable names are unique, and attached to the annotated send node"

	nextAlias ifNil: [ nextAlias := 0 ].
	nextAlias := nextAlias + 1.
	^ '$', nextAlias asString
! !

!IRASTResolver methodsFor: 'visiting'!

resolve: aNode
	aNode isBlockSequenceNode ifFalse: [
		aNode nodes do: [ :each | self resolve: each ]].
	aNode shouldBeAliased ifTrue: [
			| alias |
			alias := self nextAlias.
			self builder method internalVariables add: alias.
			self builder alias
				with: [ self builder variable: (AliasVar new 
					name: alias;
					node: aNode;
					yourself) ];
				with: [ self visit: aNode resolving: false ].
				aNode alias: alias ]
!

visit: aNode
	self visit: aNode resolving: aNode canAliasChildren
!

visit: aNode resolving: aBoolean
	aBoolean ifTrue: [ self resolve: aNode ].
	aNode isAliased 
		ifTrue: [ self visitAliased: aNode ]
		ifFalse: [ super visit: aNode ]
!

visitAliased: aNode
	^ self builder variable: (AliasVar new 
		name: aNode alias;
		node: aNode;
		yourself)
!

visitCascadeNode: aNode
	"Special care must be taken for cascade nodes.
	Only the last node should be aliased if any"

	aNode nodes allButLast do: [ :each |
		self visit: each resolving: false ].
	self visit: aNode nodes last
! !

Object subclass: #IRBuilder
	instanceVariableNames: 'method root nextPc'
	package: 'Compiler-IR'!
!IRBuilder commentStamp!
I am responsible for building the IR (Intermatiate Representation) graph, composed of IRInstruction objects.!

!IRBuilder methodsFor: 'accessing'!

method
	^ method
!

nextPc
	nextPc ifNil: [ nextPc := 0 ].
	nextPc := nextPc + 1.
	^ nextPc
!

root
	^ root
!

root: anIRInstruction
	root := anIRInstruction
! !

!IRBuilder methodsFor: 'building'!

add: aClass
	^ self root append: (aClass on: self)
!

alias
	^ self add: IRAlias
!

append: anObject
	^root append: anObject
!

assignment
	^ self add: IRAssignment
!

blockSequence
	^ self add: IRBlockSequence
!

closure
	^ self add: IRClosure
!

nonLocalReturn
	^ self add: IRNonLocalReturn
!

nonLocalReturnHandling
	^ self add: IRNonLocalReturnHandling
!

return
	^ self add: IRReturn
!

send
	^ self add: IRSend
!

sequence
	^ self add: IRSequence
!

statement
	^ self add: IRStatement
!

tempDeclaration
	^ self add: IRTempDeclaration
!

value
	^ self add: IRValue
!

value: aString
	^ self value
		value: aString;
		yourself
!

variable
	^ self add: IRVariable
!

variable: aScopeVariable
	^ self variable
		variable: aScopeVariable;
		yourself
!

verbatim: aString
	^(self add: IRVerbatim)
		source: aString;
		yourself
!

with: anObject
	self root with: anObject
! !

!IRBuilder methodsFor: 'emiting'!

emitOn: aStream
	method emitOn: aStream
! !

!IRBuilder methodsFor: 'initialization'!

initialize
	super initialize.
	root := method := IRMethod on: self
! !

Object subclass: #IRInstruction
	instanceVariableNames: 'builder instructions'
	package: 'Compiler-IR'!
!IRInstruction commentStamp!
I am the abstract root class of the IR (intermediate representation) instructions class hierarchy.
The IR graph is used to emit JavaScript code using a JSStream.!

!IRInstruction methodsFor: 'accessing'!

builder
	^ builder
!

builder: aBuilder
	builder := aBuilder
!

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

!IRInstruction methodsFor: 'building'!

append: anObject
	anObject appendToInstruction: self.
	^ anObject
!

appendBlock: aBlock
	| root |
	root := self builder root.
	self builder root: self.
	aBlock value.
	self builder root: root
!

appendInstruction: anIRInstruction
	self instructions add: anIRInstruction
!

appendString: aString
	self append: (self builder value: aString)
!

appendToInstruction: anIRInstruction
	anIRInstruction appendInstruction: self
!

with: anObject
	anObject appendToInstruction: self
! !

!IRInstruction methodsFor: 'testing'!

isClosure
	^ false
!

isReturn
	^ false
! !

!IRInstruction methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRInstruction: self
! !

!IRInstruction class methodsFor: 'instance creation'!

on: aBuilder
	^ self new
		builder: aBuilder;
		yourself
! !

IRInstruction subclass: #IRAssignment
	instanceVariableNames: ''
	package: 'Compiler-IR'!

!IRAssignment methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRAssignment: self
! !

IRAssignment subclass: #IRAlias
	instanceVariableNames: ''
	package: 'Compiler-IR'!

!IRAlias methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRAlias: self
! !

IRInstruction subclass: #IRClosure
	instanceVariableNames: 'arguments'
	package: 'Compiler-IR'!

!IRClosure methodsFor: 'accessing'!

arguments
	^ arguments ifNil: [ #() ]
!

arguments: aCollection
	arguments := aCollection
! !

!IRClosure methodsFor: 'testing'!

isClosure
	^ true
! !

!IRClosure methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRClosure: self
! !

IRInstruction subclass: #IRMethod
	instanceVariableNames: 'source selector classReferences messageSends arguments internalVariables'
	package: 'Compiler-IR'!
!IRMethod commentStamp!
I am a method instruction!

!IRMethod methodsFor: 'accessing'!

arguments
	^ arguments
!

arguments: aCollection
	arguments := aCollection
!

classReferences
	^ classReferences
!

classReferences: aCollection
	classReferences := aCollection
!

internalVariables
	^ internalVariables ifNil: [ internalVariables := Set new ]
!

messageSends
	^ messageSends
!

messageSends: aCollection
	messageSends := aCollection
!

selector
	^ selector
!

selector: aString
	selector := aString
!

source
	^ source
!

source: aString
	source := aString
! !

!IRMethod methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRMethod: self
! !

IRInstruction subclass: #IRNonLocalReturnHandling
	instanceVariableNames: ''
	package: 'Compiler-IR'!
!IRNonLocalReturnHandling commentStamp!
I represent a non local return handling instruction.
Non local returns are handled with a try/catch statement!

!IRNonLocalReturnHandling methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRNonLocalReturnHandling: self
! !

IRInstruction subclass: #IRReturn
	instanceVariableNames: ''
	package: 'Compiler-IR'!
!IRReturn commentStamp!
I am a local return instruction.!

!IRReturn methodsFor: 'testing'!

isReturn
	^ true
! !

!IRReturn methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRReturn: self
! !

IRReturn subclass: #IRNonLocalReturn
	instanceVariableNames: ''
	package: 'Compiler-IR'!
!IRNonLocalReturn commentStamp!
I am a non local return instruction.
Non local returns are handled using a try/catch JS statement.

See IRNonLocalReturnHandling class!

!IRNonLocalReturn methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRNonLocalReturn: self
! !

IRInstruction subclass: #IRSend
	instanceVariableNames: 'selector classSend'
	package: 'Compiler-IR'!
!IRSend commentStamp!
I am a message send instruction.!

!IRSend methodsFor: 'accessing'!

classSend
	^ classSend
!

classSend: aClass
	classSend := aClass
!

selector
	^ selector
!

selector: aString
	selector := aString
! !

!IRSend methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRSend: self
! !

IRInstruction subclass: #IRSequence
	instanceVariableNames: ''
	package: 'Compiler-IR'!

!IRSequence methodsFor: 'adding'!

appendInstruction: anIRInstruction
	self instructions add: ((IRStatement on: self builder) with: anIRInstruction)
! !

!IRSequence methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRSequence: self
! !

IRSequence subclass: #IRBlockSequence
	instanceVariableNames: ''
	package: 'Compiler-IR'!

!IRBlockSequence methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRBlockSequence: self
! !

IRInstruction subclass: #IRStatement
	instanceVariableNames: 'pc'
	package: 'Compiler-IR'!
!IRStatement commentStamp!
I am a statement instruction. 
Statements can be used to control the PC count, among other things.!

!IRStatement methodsFor: 'accessing'!

pc
	^ pc ifNil: [pc := self builder nextPc]
! !

!IRStatement methodsFor: 'testing'!

isReturn
	^ self instructions first isReturn
! !

!IRStatement methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRStatement: self
! !

IRInstruction subclass: #IRTempDeclaration
	instanceVariableNames: 'name'
	package: 'Compiler-IR'!
!IRTempDeclaration commentStamp!
I am a temporary variable declaration instruction!

!IRTempDeclaration methodsFor: 'accessing'!

name
	^ name
!

name: aString
	name := aString
! !

!IRTempDeclaration methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRTempDeclaration: self
! !

IRInstruction subclass: #IRValue
	instanceVariableNames: 'value'
	package: 'Compiler-IR'!
!IRValue commentStamp!
I am the simplest possible instruction. I represent a value.!

!IRValue methodsFor: 'accessing'!

value
	^value
!

value: aString
	value := aString
! !

!IRValue methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRValue: self
! !

IRInstruction subclass: #IRVariable
	instanceVariableNames: 'variable'
	package: 'Compiler-IR'!
!IRVariable commentStamp!
I am a variable instruction.!

!IRVariable methodsFor: 'accessing'!

variable
	^ variable
!

variable: aScopeVariable
	variable := aScopeVariable
! !

!IRVariable methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRVariable: self
! !

IRInstruction subclass: #IRVerbatim
	instanceVariableNames: 'source'
	package: 'Compiler-IR'!

!IRVerbatim methodsFor: 'accessing'!

source
	^ source
!

source: aString
	source := aString
! !

!IRVerbatim methodsFor: 'visiting'!

accept: aVisitor
	aVisitor visitIRVerbatim: self
! !

Object subclass: #IRVisitor
	instanceVariableNames: ''
	package: 'Compiler-IR'!

!IRVisitor methodsFor: 'visiting'!

visit: anIRInstruction
	anIRInstruction accept: self
!

visitIRAlias: anIRAlias
	self visitIRAssignment: anIRAlias
!

visitIRAssignment: anIRAssignment
	self visitIRInstruction: anIRAssignment
!

visitIRBlockSequence: anIRBlockSequence
	self visitIRSequence: anIRBlockSequence
!

visitIRClosure: anIRClosure
	self visitIRInstruction: anIRClosure
!

visitIRInlinedClosure: anIRClosure
	self visitIRClosure: anIRClosure
!

visitIRInlinedIfTrue: anIRInlinedIfTrue
	self visitIRInlinedSend: anIRInlinedIfTrue
!

visitIRInlinedSend: anIRInlinedSend
	self visitIRSend: anIRInlinedSend
!

visitIRInstruction: anIRInstruction
	anIRInstruction instructions do: [ :each | self visit: each ]
!

visitIRMethod: anIRMethod
	self visitIRInstruction: anIRMethod
!

visitIRNonLocalReturn: anIRNonLocalReturn
	self visitIRInstruction: anIRNonLocalReturn
!

visitIRNonLocalReturnHandling: anIRNonLocalReturnHandling
	self visitIRInstruction: anIRNonLocalReturnHandling
!

visitIRReturn: anIRReturn
	self visitIRInstruction: anIRReturn
!

visitIRSend: anIRSend
	self visitIRInstruction: anIRSend
!

visitIRSequence: anIRSequence
	self visitIRInstruction: anIRSequence
!

visitIRStatement: anIRStatement
	self visitIRInstruction: anIRStatement
!

visitIRTempDeclaration: anIRTempDeclaration
	self visitIRInstruction: anIRTempDeclaration
!

visitIRValue: anIRValue
	self visitIRInstruction: anIRValue
!

visitIRVariable: anIRVariable
	self visitIRInstruction: anIRVariable
!

visitIRVerbatim: anIRVerbatim
	self visitIRInstruction: anIRVerbatim
! !

IRVisitor subclass: #IRJSTranslator
	instanceVariableNames: 'stream'
	package: 'Compiler-IR'!

!IRJSTranslator methodsFor: 'accessing'!

contents
	^ self stream contents
!

stream
	^ stream
!

stream: aStream
	stream := aStream
! !

!IRJSTranslator methodsFor: 'initialization'!

initialize
	super initialize.
	stream := JSStream new.
! !

!IRJSTranslator methodsFor: 'visiting'!

visitIRAssignment: anIRAssignment
	self visit: anIRAssignment instructions first.
	self stream nextPutAssignment.
	self visit: anIRAssignment instructions last.
!

visitIRBlockSequence: anIRBlockSequence
	self stream nextPutSequenceWith: [
		anIRBlockSequence instructions notEmpty ifTrue: [
			anIRBlockSequence instructions allButLast do: [ :each | 
				self visit: each ].
			anIRBlockSequence instructions last isReturn ifFalse: [
				self stream nextPutReturn ].
			self visit: anIRBlockSequence instructions last ]]
!

visitIRClosure: anIRClosure
	self stream 
		nextPutClosureWith: [ super visitIRClosure: anIRClosure ] 
		arguments: anIRClosure arguments
!

visitIRMethod: anIRMethod
	self stream
		nextPutMethodDeclaration: anIRMethod 
		with: [ self stream 
			nextPutFunctionWith: [ 
				anIRMethod internalVariables notEmpty ifTrue: [
					self stream nextPutVars: anIRMethod internalVariables ].
				super visitIRMethod: anIRMethod ]
			arguments: anIRMethod arguments ]
!

visitIRNonLocalReturn: anIRNonLocalReturn
	self stream nextPutNonLocalReturnWith: [
		super visitIRNonLocalReturn: anIRNonLocalReturn ]
!

visitIRNonLocalReturnHandling: anIRNonLocalReturnHandling
	self stream nextPutNonLocalReturnHandlingWith: [
		super visitIRNonLocalReturnHandling: anIRNonLocalReturnHandling ]
!

visitIRReturn: anIRReturn
	self stream nextPutReturnWith: [
		super visitIRReturn: anIRReturn ]
!

visitIRSend: anIRSend
	self stream nextPutAll: 'smalltalk.send('.
	self visit: anIRSend instructions first.
	self stream nextPutAll:  ',"', anIRSend selector asSelector, '",['.
	anIRSend instructions allButFirst
		do: [ :each | self visit: each ]
		separatedBy: [ self stream nextPutAll: ',' ].
	self stream nextPutAll: ']'.
	anIRSend classSend ifNotNil: [  
		self stream nextPutAll: ',', anIRSend classSend asJavascript ].
	self stream nextPutAll: ')'
!

visitIRSequence: anIRSequence
	self stream nextPutSequenceWith: [
		"self instructions do: [ :each |
			((IRStatement on: self builder)
				pc: self builder nextPc;
				with: each;
				yourself) emitOn: aStream ]"
		super visitIRSequence: anIRSequence ]
!

visitIRStatement: anIRStatement
	self stream nextPutStatementWith: [
		super visitIRStatement: anIRStatement ]
!

visitIRTempDeclaration: anIRTempDeclaration
	self stream nextPutVar: anIRTempDeclaration name asVariableName
!

visitIRValue: anIRValue
	self stream nextPutAll: anIRValue value asJavascript
!

visitIRVariable: anIRVariable
	self stream nextPutAll: anIRVariable variable alias
!

visitIRVerbatim: anIRVerbatim
	self stream nextPutStatementWith: [
		self stream nextPutAll: anIRVerbatim source ]
! !

Object subclass: #JSStream
	instanceVariableNames: 'stream'
	package: 'Compiler-IR'!

!JSStream methodsFor: 'accessing'!

contents
	^ stream contents
! !

!JSStream methodsFor: 'initialization'!

initialize
	super initialize.
	stream := '' writeStream.
! !

!JSStream methodsFor: 'streaming'!

lf
	stream lf
!

nextPut: aString
	stream nextPut: aString
!

nextPutAll: aString
	stream nextPutAll: aString
!

nextPutAssignment
	stream nextPutAll: '='
!

nextPutClosureWith: aBlock arguments: anArray
	stream nextPutAll: '(function('.
	anArray 
		do: [ :each | stream nextPutAll: each asVariableName ]
		separatedBy: [ stream nextPut: ',' ].
	stream nextPutAll: '){'; lf.
	aBlock value.
	stream nextPutAll: '})'
!

nextPutFunctionWith: aBlock arguments: anArray
	stream nextPutAll: 'fn: function('.
	anArray 
		do: [ :each | stream nextPutAll: each asVariableName ]
		separatedBy: [ stream nextPut: ',' ].
	stream nextPutAll: '){'; lf.
	stream nextPutAll: 'var self=this;'; lf.
	aBlock value.
	stream nextPutAll: '}'
!

nextPutIf: aBlock with: anotherBlock
	stream nextPutAll: 'if('.
	aBlock value.
	stream nextPutAll: '){'; lf.
	anotherBlock value.
	stream nextPutAll: '}'
!

nextPutMethodDeclaration: aMethod with: aBlock
	stream 
		nextPutAll: 'smalltalk.method({'; lf;
		nextPutAll: 'selector: "', aMethod selector, '",'; lf;
		nextPutAll: 'source: ', aMethod source asJavascript, ',';lf.
	aBlock value.
	stream 
		nextPutAll: ',', String lf, 'messageSends: ';
		nextPutAll: aMethod messageSends asArray asJavascript, ','; lf;
          	nextPutAll: 'args: ', (aMethod arguments collect: [ :each | each value ]) asArray asJavascript, ','; lf;
		nextPutAll: 'referencedClasses: ['.
	aMethod classReferences 
		do: [:each | stream nextPutAll: each asJavascript]
		separatedBy: [stream nextPutAll: ','].
	stream 
		nextPutAll: ']';
		nextPutAll: '})'
!

nextPutNonLocalReturnHandlingWith: aBlock
	stream 
		nextPutAll: 'var $early={};'; lf;
		nextPutAll: 'try {'; lf.
	aBlock value.
	stream 
		nextPutAll: '}'; lf;
		nextPutAll: 'catch(e) {if(e===$early)return e[0]; throw e}'; lf
!

nextPutNonLocalReturnWith: aBlock
	stream nextPutAll: 'throw $early=['.
	aBlock value.
	stream nextPutAll: ']'
!

nextPutReturn
	stream nextPutAll: 'return '
!

nextPutReturnWith: aBlock
	self nextPutReturn.
	aBlock value
!

nextPutSendTo: receiver selector: selector arguments: arguments
	stream nextPutAll: 'smalltalk.send('.
	receiver emitOn: self. 
	stream nextPutAll: ',"', selector asSelector, '",['.
	arguments 
		do: [ :each | each emitOn: self ]
		separatedBy: [ stream nextPutAll: ',' ].
	stream nextPutAll: '])'
!

nextPutSequenceWith: aBlock
	"stream 
		nextPutAll: 'switch(smalltalk.thisContext.pc){'; lf."
	aBlock value.
	"stream 
		nextPutAll: '};'; lf"
!

nextPutStatement: anInteger with: aBlock
	stream nextPutAll: 'case ', anInteger asString, ':'; lf.
	self nextPutStatementWith: aBlock.
	stream nextPutAll: 'smalltalk.thisContext.pc=', (anInteger + 1) asString, ';'; lf
!

nextPutStatementWith: aBlock
	aBlock value.
	stream nextPutAll: ';'; lf
!

nextPutVar: aString
	stream nextPutAll: 'var ', aString, ';'; lf
!

nextPutVars: aCollection
	stream nextPutAll: 'var '.
	aCollection 
		do: [ :each | stream nextPutAll: each ]
		separatedBy: [ stream nextPutAll: ',' ].
	stream nextPutAll: ';'; lf
! !

!BlockClosure methodsFor: '*Compiler-IR'!

appendToInstruction: anIRInstruction
    anIRInstruction appendBlock: self
! !

!String methodsFor: '*Compiler-IR'!

appendToInstruction: anInstruction
	anInstruction appendString: self
!

asVariableName
	^ (Smalltalk current reservedWords includes: self)
		ifTrue: [ self, '_' ]
		ifFalse: [ self ]
!

emitOn: aStream
	aStream nextPutAll: self
! !