compiler/PPCNode.st
author Jan Vrany <jan.vrany@fit.cvut.cz>
Wed, 15 Apr 2015 11:28:09 +0100
changeset 422 116d2b2af905
parent 421 7e08b31e0dae
child 438 20598d7ce9fa
permissions -rw-r--r--
To fold

"{ Package: 'stx:goodies/petitparser/compiler' }"

"{ NameSpace: Smalltalk }"

Object subclass:#PPCNode
	instanceVariableNames:'contextFree name firstFollowCache firstCharSet properties'
	classVariableNames:''
	poolDictionaries:''
	category:'PetitCompiler-Nodes'
!

!PPCNode class methodsFor:'as yet unclassified'!

new
	^ self basicNew initialize
! !

!PPCNode methodsFor:'accessing'!

children
	^ #()
!

name: anObject
	
	name := anObject
!

prefix
	self subclassResponsibility 
!

suffix
	^ ''
! !

!PPCNode methodsFor:'accessing-properties'!

hasProperty: aKey
	"Test if the property aKey is present."
	
	^ properties notNil and: [ properties includesKey: aKey ]
!

properties: aDictionary
	properties := aDictionary 
!

propertyAt: aKey ifAbsent: aBlock
	"Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."
	
	^ properties isNil
		ifTrue: [ aBlock value ]
		ifFalse: [ properties at: aKey ifAbsent: aBlock ]
! !

!PPCNode methodsFor:'analysis'!

acceptsEpsilon
	"return true, if parser can accept epsilon without failure"
	^ self subclassResponsibility
!

acceptsEpsilonOpenSet: set
	"private helper for acceptsEmpsilon that makes sure to avoid cycles (using open set)"
	self children isEmpty ifTrue: [ ^ self acceptsEpsilon ].
	
	self shouldBeImplemented .
!

allNodes
	| result |
	result := OrderedCollection new.
	self allParsersDo: [ :parser | result add: parser ].
	^ result
!

allNodesDo: aBlock
	"Iterate over all the parse nodes of the receiver."

	self allNodesDo: aBlock seen: IdentitySet new
!

allNodesDo: aBlock seen: aSet
	"Iterate over all the parse nodes of the receiver, do not visit and follow the ones contained in aSet."

	(aSet includes: self)
		ifTrue: [ ^ self ].
	aSet add: self.
	aBlock value: self.
	self children
		do: [ :each | each allNodesDo: aBlock seen: aSet ]
!

check
	"nothing to do"
	^ nil
!

firstCharSetCached
	firstCharSet ifNil: [ 
 		firstCharSet := self firstCharSet.
	].
	^ firstCharSet
!

firstSetSuchThat: block
	^ self firstSetSuchThat: block into: (OrderedCollection new) openSet: IdentitySet new.
!

firstSetSuchThat: block into: aCollection openSet: aSet
	(aSet includes: self) ifTrue: [ ^ aCollection ].
	aSet add: self.
	
	(block value: self) ifTrue: [aCollection add: self. ^ aCollection ].
	self children do: [ :child | 
		child firstSetSuchThat: block into: aCollection openSet: aSet 
	].
	^ aCollection
!

isContextFree
	^ contextFree ifNil: [ contextFree := self allNodes allSatisfy: [ :n | n isContextFreePrim  ] ]
!

isContextFreePrim
	^ true
!

isFirstSetTerminal
	"Answer true if the receiver is a terminal or leaf parser, that means it does not delegate to any other parser."

	^ self isTerminal
!

isNullable
	"Answer true if the receiver is a nullable parser, e.g. it can successfully parse nothing."
	
	^ false
!

isTerminal
	"Answer true if the receiver is a terminal or leaf parser, that means it does not delegate to any other parser."

	^ self children isEmpty
! !

!PPCNode methodsFor:'as yet unclassified'!

name
	^ name
! !

!PPCNode methodsFor:'comparison'!

= anotherNode
	(self == anotherNode) ifTrue: [ ^ true ].
	(anotherNode class = self class) ifFalse: [ ^ false ].
	
	(anotherNode name = name) ifFalse: [ ^ false ].
	^ anotherNode children = self children.
!

hash
	"TODO JK: IMO not a good hashing function bacause of children size, 
		but at least it is not recursive, which would be worse :)
	"
	^ self class hash bitXor: (name hash bitXor: self children size hash)
! !

!PPCNode methodsFor:'compiling'!

compileWith: compiler
	|  |
	^ self compileWith: compiler effect: #none
!

compileWith: compiler effect: effect
	| id method |
	id := (compiler idFor: self prefixed: (self prefix) suffixed: (self suffix) effect: effect).
	(method := compiler checkCache: id) ifNotNil: [ ^ method ].

	^ self compileWith: compiler effect: effect id: id.
!

compileWith: compiler effect: effect id: id
	self subclassResponsibility 
!

initialize
	super initialize.
	firstFollowCache := IdentityDictionary new.
! !

!PPCNode methodsFor:'first follow next'!

firstSet
	^ firstFollowCache at: #firstSet ifAbsentPut: [
		self firstSets at: self
	]
!

firstSet: set
	firstFollowCache at: #firstSet put: set
!

firstSets
	^ self firstSetsSuchThat: [ :e | e isFirstSetTerminal ]
!

firstSets: aFirstDictionary into: aSet suchThat: aBlock
	"PRIVATE: Try to add additional elements to the first-set aSet of the receiver, use the incomplete aFirstDictionary."

	(aBlock value: self) ifFalse: [ 
		self children do: [ :node | aSet addAll: (aFirstDictionary at: node) ]
	]
!

firstSetsSuchThat: block

	| firstSets |
	firstSets := IdentityDictionary new.
	self allParsersDo: [ :each |
		firstSets at: each put: ((block value: each)
			ifTrue: [ IdentitySet with: each ]
			ifFalse: [ IdentitySet new ]).
		each isNullable
			ifTrue: [ (firstSets at: each) add: PPCSentinelNode instance ] ].
		
		
	[	| changed tally |
		changed := false.
		firstSets keysAndValuesDo: [ :node :first |
			tally := first size.
			node firstSets: firstSets into: first suchThat: block.
			changed := changed or: [ tally ~= first size ] ].
		changed ] whileTrue.
	^ firstSets
!

followSet
	^ firstFollowCache at: #followSet ifAbsent: [ self error: 'no follow set cached' ]
!

followSet: aSet
	^ firstFollowCache at: #followSet put: aSet
!

followSetIn: rootNode
	^ rootNode followSets at: self
!

followSetWithTokens
	^ firstFollowCache at: #followSetWithTokens ifAbsent: [ self error: 'no follow with tokens cached' ]
!

followSetWithTokens: aSet
	^ firstFollowCache at: #followSetWithTokens put: aSet
!

followSets
	^ self followSetsSuchThat: [ :e | e isFirstSetTerminal ]
!

followSets: aFollowDictionary firstSets: aFirstDictionary into: aSet suchThat: aBlock
	"PRIVATE: Try to add additional elements to the follow-set aSet of the receiver, use the incomplete aFollowDictionary and the complete aFirstDictionary."
	
	self children do: [ :node | (aFollowDictionary at: node) addAll: aSet ]
!

followSetsSuchThat: aBlock
	"Answer a dictionary with all the parsers reachable from the receiver as key and their follow-set as value. The follow-set of a parser is the list of terminal parsers that can appear immediately to the right of that parser."
	
	| current previous continue firstSets followSets |
	current := previous := 0.
	firstSets := self firstSetsSuchThat: aBlock.
	followSets := IdentityDictionary new.
	self allNodesDo: [ :each | followSets at: each put: IdentitySet new ].
	(followSets at: self) add: PPCSentinelNode instance.
	[	followSets keysAndValuesDo: [ :node :follow |
			node 
				followSets: followSets
				firstSets: firstSets
				into: follow
				suchThat: aBlock ].
		current := followSets
			inject: 0
			into: [ :result :each | result + each size ].
		continue := previous < current.
		previous := current.
		continue ] whileTrue.
	^ followSets
!

nextSetIn: rootNode
	^ rootNode nextSets at: self
!

nextSets
		| nextSets |
	
	nextSets := IdentityDictionary new.
	self allNodesDo: [ :each | nextSets at: each put: IdentitySet new ].
	
	(nextSets at: self) add: PPCSentinelNode instance.
	
	[ 	| changed |
		changed := false.
	
		nextSets keysAndValuesDo: [:node :next |
			changed := (node 
				nextSets: nextSets
				into: next) or: [ changed ].
		].
		changed ] whileTrue.
	
	^ nextSets
!

nextSets: aNextDictionary into: aSet
	"return true/false, if something has changed or not...."
	| childSet change tally |
	
	change := false.
	
	self children do: [:each | 
		childSet := aNextDictionary at: each.
		tally := childSet size.
		childSet addAll: aSet.
		change := change or: [ tally ~= childSet size ].
	].

	^ change
	
! !

!PPCNode methodsFor:'gt'!

gtTreeViewIn: composite
	<gtInspectorPresentationOrder: 40>

	composite tree
			title: 'Tree';
			children: [:n | n children ];
			format: [:n| n name ifNil: [ n asString ] ifNotNil: [n name] ];
			shouldExpandToLevel: 6
! !

!PPCNode methodsFor:'optimizing'!

asFast
	^ self
!

asInlined
	^ self
!

checkTree
	| message |
	self allNodes do: [ :node | (message := node check) ifNotNil: [ self error: message ]  ].
!

defaultOptimizationParameters
	| parameters |
	parameters := IdentityDictionary new.
	parameters at: #inline put: true.
	parameters at: #rewrite put: true.

	^ parameters
!

doOptimizationLoop: params status: changeStatus
	| mapping optimized root |
	mapping := IdentityDictionary new.
	self allNodes do: [ :node |
		optimized := (node optimize: params status: changeStatus).
		(optimized ~= node) ifTrue: [  
			mapping at: node put: optimized.
		].
	].
	
	root := mapping at: self ifAbsent: [ self ].
	[  | changed |
		changed := false.
		root allNodes do: [ :node |
			node children do: [ :child | 
				mapping at: child ifPresent: [:newChild | 
					node replace: child with: newChild.
					changed := true ]
		]].
		changed 
	] whileTrue.
	^ root
!

inline: changeStatus
	"nothing to do"
!

inline: params status: changeStatus
	(params at: #inline) ifTrue: [ 
		^ self inline: changeStatus
	]
!

optimize: params status: changeStatus
	| retval |
	retval := self.
	
	retval := retval rewrite: params status: changeStatus.
	retval := retval inline: params status: changeStatus.
	
	^ retval
!

optimizeTree
	^ self optimizeTree: #()
!

optimizeTree: params
	|  node newNode parameters status |
	
	parameters := self defaultOptimizationParameters.
	
	params do: [ :p | parameters at: p key put: p value ].
	
	node := self.
	[ 
		status := PPCOptimizationResult new.
		newNode := node doOptimizationLoop: parameters status: status.
		status isChange.
	] whileTrue: [ node := newNode ].
	^ node
!

rewrite: changeStatus
	"nothing to do"
!

rewrite: params status: changeStatus
	(params at: #rewrite) ifTrue: [  
		^ self rewrite: changeStatus.
	].
! !

!PPCNode methodsFor:'printing'!

printNameOn: aStream
	self name isNil
		ifTrue: [ aStream print: self hash ]
		ifFalse: [ aStream nextPutAll: self name. aStream nextPut: $-. aStream print: self hash. ]
!

printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	self printNameOn: aStream.
	aStream nextPut: $)
! !

!PPCNode methodsFor:'todel'!

allParsersDo: aBlock
	"Iterate over all the parse nodes of the receiver."

	self allParsersDo: aBlock seen: IdentitySet new
!

allParsersDo: aBlock seen: aSet
	"Iterate over all the parse nodes of the receiver, do not visit and follow the ones contained in aSet."

	(aSet includes: self)
		ifTrue: [ ^ self ].
	aSet add: self.
	aBlock value: self.
	self children
		do: [ :each | each allParsersDo: aBlock seen: aSet ]
! !

!PPCNode methodsFor:'transformation'!

asCompilerNode
	^ self
!

replace: node with: anotherNode
!

transform: aBlock
	"Answer a copy of all parsers reachable from the receiver transformed using aBlock."

	| mapping root |
	mapping := IdentityDictionary new.
	self allParsersDo: [ :each |
		mapping
			at: each
			put: (aBlock value: each copy) ].
	root := mapping at: self.
	[	| changed |
		changed := false.
		root allParsersDo: [ :each |
			each children do: [ :old |
				mapping at: old ifPresent: [ :new |
					each replace: old with: new.
					changed := true ] ] ].
		changed ] whileTrue.
	^ root
! !