SystemOrganization addCategory: #'PetitBeta-Optimizer'!
SystemOrganization addCategory: #'PetitBeta-JIT'!

TestResource subclass: #PPJitResource
	instanceVariableNames: 'jitter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-JIT'!

!PPJitResource methodsFor: 'accessing' stamp: 'lr 8/6/2010 19:17'!
jitter
	^ jitter! !

!PPJitResource methodsFor: 'running' stamp: 'lr 8/7/2010 10:21'!
setUp
	super setUp.
	jitter := PPJit new! !

!PPParser methodsFor: '*petitbeta-operations' stamp: 'lr 4/16/2010 15:43'!
dynamicChoice: aParser
	| dynamicChoice |
	^ dynamicChoice := self | aParser / [ :stream |
		| resolution |
		resolution := UIManager default
			chooseFrom: { self name. aParser name }
			values: { self. aParser }
			title: 'Resolve ambiguity'.
		dynamicChoice def: resolution.
		resolution parseOn: stream ] asParser! !

!PPParser methodsFor: '*petitbeta-operations' stamp: 'lr 4/29/2010 23:13'!
optimize
	"Optimizes the receiving parser for speed and size."

	^ PPOptimizer new optimize: self! !

!PPParser methodsFor: '*petitbeta-operations' stamp: 'lr 4/16/2010 21:09'!
whatFollows: aString at: anInteger
	| stream |
	stream := aString asPetitStream.
	(self transform: [ :parser |
		parser ==> [ :node |
			stream position < anInteger
				ifTrue: [ node ]
				ifFalse: [ ^ parser followSets ] ] ])
		parseOn: stream.
	^ #()! !

PPAbstractParseTest subclass: #PPOptimizerTest
	instanceVariableNames: 'a b c'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Optimizer'!

!PPOptimizerTest class methodsFor: 'accessing' stamp: 'lr 5/31/2010 18:50'!
packageNamesUnderTest
	^ #('PetitBeta')! !

!PPOptimizerTest methodsFor: 'utilities' stamp: 'lr 8/26/2010 10:58'!
assert: aParser equals: anotherParser
	self 
		assert: (aParser match: anotherParser inContext: Dictionary new)
		description: (self comparingStringBetween: aParser and: anotherParser)! !

!PPOptimizerTest methodsFor: 'utilities' stamp: 'lr 4/29/2010 23:21'!
optimize: aParser
	^ aParser optimize! !

!PPOptimizerTest methodsFor: 'running' stamp: 'lr 8/26/2010 11:08'!
setUp
	super setUp.
	a := $a asParser.
	b := $b asParser.
	c := $c asParser! !

!PPOptimizerTest methodsFor: 'testing' stamp: 'lr 9/15/2010 11:52'!
testDuplicates
	| grammar |
	grammar := self optimize: $a asParser , $a asParser.
	self assert: grammar children first = grammar children last.
	self deny:  $a asParser = $a asParser! !

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 8/26/2010 10:57'!
testEmptyChoice
	| grammar |
	grammar := self optimize: PPChoiceParser new.
	self assert: grammar equals: PPFailingParser new! !

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 8/26/2010 10:59'!
testNestedChoice
	| grammar |
	grammar := self optimize: a / (b / c).
	self assert: grammar equals: a / b / c.

	grammar := self optimize: (a / b) / c.
	self assert: grammar equals: a / b / c! !

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 8/26/2010 11:00'!
testNulledChoice
	| grammar |
	grammar := self optimize: a / nil asParser / b / c.
	self assert: grammar equals: a optional.

	grammar := self optimize: a / b / nil asParser / c.
	self assert: grammar equals: a / b / nil asParser.
	
	grammar := self optimize: a / b / c / nil asParser.
	self assert: grammar equals: a / b / c / nil asParser! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:10'!
testOptionalChoice
	| grammar |
	grammar := self optimize: a optional / a.
	self assert: grammar equals: a optional! !

!PPOptimizerTest methodsFor: 'testing-epsilon' stamp: 'lr 8/26/2010 11:09'!
testOptionalEpsilon
	| grammar |
	grammar := self optimize: nil asParser optional.
	self assert: grammar equals: nil asParser! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:10'!
testOptionalOptional
	| grammar |
	grammar := self optimize: a optional optional.
	self assert: grammar equals: a optional! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:11'!
testOptionalPlus
	| grammar |
	grammar := self optimize: a optional plus.
	self assert: grammar equals: a star! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:11'!
testOptionalPlusChoice
	| grammar |
	grammar := self optimize: a optional / a plus.
	self assert: grammar equals: a star! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:11'!
testOptionalStar
	| grammar |
	grammar := self optimize: a optional star.
	self assert: grammar equals: a star! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:11'!
testOptionalStarChoice
	| grammar |
	grammar := self optimize: a optional / a star.
	self assert: grammar equals: a star! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:12'!
testPlusChoice
	| grammar |
	grammar := self optimize: a plus / a.
	self assert: grammar equals: a plus! !

!PPOptimizerTest methodsFor: 'testing-epsilon' stamp: 'lr 8/26/2010 11:09'!
testPlusEpsilon
	| grammar |
	grammar := self optimize: nil asParser plus.
	self assert: grammar equals: nil asParser! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:13'!
testPlusOptional
	| grammar |
	grammar := self optimize: a plus optional.
	self assert: grammar equals: a star! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:14'!
testPlusOptionalChoice
	| grammar |
	grammar := self optimize: a plus / a optional.
	self assert: grammar equals: a star! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:13'!
testPlusPlus
	| grammar |
	grammar := self optimize: a plus plus.
	self assert: grammar equals: a plus! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:13'!
testPlusStar
	| grammar |
	grammar := self optimize: a plus star.
	self assert: grammar equals: a star! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:14'!
testPlusStarChoice
	| grammar |
	grammar := self optimize: a plus / a star.
	self assert: grammar equals: a star! !

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 8/26/2010 11:00'!
testPostfixChoice
	| grammar |
	grammar := self optimize: (a , b) / (c , b).
	self assert: grammar equals: (a / c) , b! !

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 8/26/2010 11:00'!
testPrefixChoice
	| grammar |
	grammar := self optimize: (a , b) / (a , c).
	self assert: grammar equals: a , (b / c)! !

!PPOptimizerTest methodsFor: 'testing-delegate' stamp: 'lr 8/26/2010 11:03'!
testReduceDelegate
	| grammar |
	grammar := self optimize: (PPAndParser on: (PPAndParser on: a)).
	self assert: grammar equals: a and.
	
	grammar := self optimize: (PPFlattenParser on: (PPFlattenParser on: a)).
	self assert: grammar equals: a flatten.
	
	grammar := self optimize: (PPTokenParser on: (PPTokenParser on: a)).
	self assert: grammar equals: a token.

	grammar := self optimize: (PPMemoizedParser on: (PPMemoizedParser on: a)).
	self assert: grammar equals: a memoized.

	grammar := self optimize: (PPTrimmingParser on: (PPTrimmingParser on: a)).
	self assert: grammar equals: a trim.
	
	grammar := self optimize: (PPNotParser on: (PPNotParser on: a)).
	self assert: grammar equals: a not not! !

!PPOptimizerTest methodsFor: 'testing-delegate' stamp: 'lr 8/26/2010 11:03'!
testRemoveDelegate
	| grammar |
	grammar := self optimize: a wrapped.
	self assert: grammar equals: a.
	
	grammar := self optimize: a wrapped wrapped.
	self assert: grammar equals: a.
	
	grammar := self optimize: a wrapped / b wrapped wrapped.
	self assert: grammar equals: a / b! !

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 8/26/2010 11:02'!
testRepeatedChoice
	| grammar |
	grammar := self optimize: a / a / b / c.
	self assert: grammar equals: a / b / c.
	
	grammar := self optimize: a / b / a / a.
	self assert: grammar equals: a / b.

	grammar := self optimize: a / a / a / a.
	self assert: grammar equals: a! !

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 8/26/2010 11:02'!
testSingleChoice
	| grammar |
	grammar := self optimize: (PPChoiceParser with: a).
	self assert: grammar equals: a! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:15'!
testStarChoice
	| grammar |
	grammar := self optimize: a star / a.
	self assert: grammar equals: a star! !

!PPOptimizerTest methodsFor: 'testing-epsilon' stamp: 'lr 8/26/2010 11:09'!
testStarEpsilon
	| grammar |
	grammar := self optimize: nil asParser star.
	self assert: grammar equals: nil asParser! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:15'!
testStarOptional
	| grammar |
	grammar := self optimize: a star optional.
	self assert: grammar equals: a star! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:15'!
testStarOptionalChoice
	| grammar |
	grammar := self optimize: a star / a optional.
	self assert: grammar equals: a star! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:16'!
testStarPlus
	| grammar |
	grammar := self optimize: a star plus.
	self assert: grammar equals: a star! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:16'!
testStarPlusChoice
	| grammar |
	grammar := self optimize: a star / a plus.
	self assert: grammar equals: a star! !

!PPOptimizerTest methodsFor: 'testing-operators' stamp: 'lr 8/26/2010 11:16'!
testStarStar
	| grammar |
	grammar := self optimize: a star star.
	self assert: grammar equals: a star! !

PPDelegateParser subclass: #PPJitParser
	instanceVariableNames: 'method'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-JIT'!

!PPJitParser class methodsFor: 'instance creation' stamp: 'lr 8/1/2010 09:02'!
on: aParser method: aCompiledMethod
	^ (self on: aParser) setMethod: aCompiledMethod! !

!PPJitParser methodsFor: 'accessing' stamp: 'lr 8/1/2010 15:51'!
method
	^ method! !

!PPJitParser methodsFor: 'parsing' stamp: 'lr 7/31/2010 23:15'!
parseOn: aStream
	^ self 
		withArgs: (Array with: aStream)
		executeMethod: method! !

!PPJitParser methodsFor: 'initialization' stamp: 'lr 7/31/2010 23:16'!
setMethod: aCompiledMethod
	method := aCompiledMethod! !

PPParserTest subclass: #PPJitTest
	instanceVariableNames: 'jitter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-JIT'!

!PPJitTest class methodsFor: 'accessing' stamp: 'lr 8/6/2010 19:17'!
resources
	^ Array with: PPJitResource! !

!PPJitTest methodsFor: 'utilities' stamp: 'lr 8/6/2010 19:18'!
assert: aParser fail: aCollection
	| parser stream result |
	parser := PPJitResource current jitter
		compile: aParser.
	self assert: (parser isKindOf: PPJitParser).
	stream := aCollection asPetitStream.
	result := parser parse: stream.
	self assert: result isPetitFailure.
	self assert: stream position = 0! !

!PPJitTest methodsFor: 'utilities' stamp: 'lr 8/6/2010 19:18'!
assert: aParser parse: aCollection to: aTargetObject end: anInteger
	| parser stream result |
	parser := PPJitResource current jitter
		compile: aParser.
	self assert: (parser isKindOf: PPJitParser).
	stream := aCollection asPetitStream.
	result := parser parse: stream.
	aTargetObject isNil
		ifTrue: [ self deny: result isPetitFailure ]
		ifFalse: [ self assert: result = aTargetObject ].
	self assert: stream position = anInteger! !

!PPJitTest methodsFor: 'testing' stamp: 'lr 8/7/2010 10:37'!
testMemoized
	"This test does not work"! !

Object subclass: #PPJit
	instanceVariableNames: 'methodTemplates inlineTemplates literalMapping'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-JIT'!

!PPJit methodsFor: 'public' stamp: 'lr 8/6/2010 19:15'!
compile: aParser
	"Try to optimize aParser. If no reasonable optimization can be performed return the original parser."
	
	| methodTree |
	methodTree := (methodTemplates
		at: aParser class
		ifAbsent: [ ^ aParser ])
			copy.
	literalMapping := IdentityDictionary new.
	
	methodTree := self inlineAll: methodTree for: aParser.
	methodTree := self
		rewrite: (self
			rewrite: (self
				rewrite: methodTree removeDeadCode
				using: self rewriteParserBlocks)
			using: self rewriteEmtpyIfTrue)
		using: self rewriteEmptyBlock.
	
	^ PPJitParser on: aParser method: (self 
		patchLiterals: (self rootParserClass compilerClass new
			compile: methodTree formattedCode
			in: self rootParserClass
			classified: nil notifying: nil
			ifFail: [ ^ aParser ])
				generate)! !

!PPJit methodsFor: 'initialization' stamp: 'lr 8/6/2010 14:55'!
initialize
	self initializeTemplates! !

!PPJit methodsFor: 'initialization' stamp: 'lr 8/6/2010 17:58'!
initializeTemplate: class
	| parseTree |
	parseTree := (class lookupSelector: self parseOnSelector)
		parseTree.
	(parseTree isNil 
		or: [ parseTree isPrimitive 
		or: [ parseTree superMessages notEmpty ] ])
			ifTrue: [ ^ self ].
	parseTree := (self
		rewrite: (self
			rewrite: (self
				rewrite: parseTree 
				using: self rewriteGuardClause)
			using: self rewriteIfTrue)
		using: self rewriteReturns)
			addSelfReturn;
			yourself.
	(parseTree body temporaries isEmpty
		and: [ parseTree body statements size = 1
		and: [ parseTree body statements first isReturn
		and: [ parseTree body statements first value containsReturn not ] ] ])
			ifTrue: [ inlineTemplates at: class put: parseTree body statements first value ].
	methodTemplates at: class put: parseTree! !

!PPJit methodsFor: 'initialization' stamp: 'lr 8/6/2010 18:24'!
initializeTemplates
	methodTemplates := IdentityDictionary new.
	inlineTemplates := IdentityDictionary new.
	self rootParserClass
		withAllSubclassesDo: [ :class | self initializeTemplate: class ]! !

!PPJit methodsFor: 'private' stamp: 'lr 8/6/2010 19:12'!
inlineAll: aNode for: aParser
	| rewriter1 rewriter2 |
	rewriter1 := RBParseTreeRewriter new.
	rewriter1
		replace: '`variable value: `@expr'
			withValueFrom: [ :node | self inlineBlock: node for: aParser ]
			when: [ :node | (self instanceVariable: node receiver for: aParser) isBlock ];
		replace: '`variable parseOn: `stream'
			withValueFrom: [ :node | self inlineParser: node for: aParser ]
			when: [ :node | (self instanceVariable: node receiver for: aParser) isPetitParser ];
		replace: '`variable `@msg: `@args'
			withValueFrom: [ :node | self inlineCollection: node for: aParser ]
			when: [ :node | (self instanceVariable: node receiver for: aParser) isCollection ].
	rewriter2 := RBParseTreeRewriter new.
	rewriter2
		replace: 'self' 
		withValueFrom: [ :node | self inlineObject: aParser ];
		replace: '`variable' 
		withValueFrom: [ :node | self inlineVariable: node for: aParser ].
	^ rewriter2 executeTree: (rewriter1 executeTree: aNode; tree); tree! !

!PPJit methodsFor: 'private' stamp: 'lr 8/7/2010 09:52'!
inlineBlock: aNode for: aParser
	| block tree |
	block := self
		instanceVariable: aNode receiver
		for: aParser.
	(block numArgs = 1 and: [ block numCopiedValues = 0 ])
		ifFalse: [ ^ aNode ].
	tree := RBParser
		parseExpression: block asString
		onError: [ :msg :pos | ^ aNode ].
	(tree isBlock and: [ tree body temporaries isEmpty and: [ tree body statements size = 1 and: [ tree containsReturn not ] ] ])
		ifFalse: [ ^ aNode ].
	tree body statements first nodesDo: [ :each |
		each isVariable ifTrue: [ 
			each name = tree arguments first name
				ifTrue: [ each replaceWith: aNode arguments first ]
				ifFalse: [ ^ aNode ] ] ].
	^ tree body statements first! !

!PPJit methodsFor: 'private' stamp: 'lr 8/6/2010 18:18'!
inlineCollection: aNode for: aParser
	| collection arguments |
	collection := self
		instanceVariable: aNode receiver
		for: aParser.
	arguments := aNode arguments collect: [ :each | 
		each isLiteral
			ifTrue: [ each value ]
			ifFalse: [ ^ aNode ] ].
	^ RBLiteralNode value: (collection
		perform: aNode selector
		withArguments: arguments)! !

!PPJit methodsFor: 'private' stamp: 'lr 8/6/2010 18:13'!
inlineObject: anObject
	"Inlines anObject into the literal frame of the generated method."
	
	^ RBLiteralNode value: (literalMapping
		at: anObject
		ifAbsentPut: [ ('__ref_' , literalMapping size asString) asSymbol ])! !

!PPJit methodsFor: 'private' stamp: 'lr 8/6/2010 17:52'!
inlineParser: aNode for: aParser
	| parser tree |
	parser := self
		instanceVariable: aNode receiver
		for: aParser.
	tree := (inlineTemplates
		at: parser class
		ifAbsent: [ ^ aNode ])
			copy.
	^ self inlineAll: tree for: parser! !

!PPJit methodsFor: 'private' stamp: 'lr 8/6/2010 16:56'!
inlineVariable: aNode for: aParser
	| value |
	value := self 
		instanceVariable: aNode for: aParser
		ifAbsent: [ ^ aNode ].
	value isLiteral
		ifTrue: [ ^ RBLiteralNode value: value ].
	^ self inlineObject: value! !

!PPJit methodsFor: 'private' stamp: 'lr 8/6/2010 17:41'!
inlineVariables: aNode for: aParser
	| rewriter |
	rewriter := RBParseTreeRewriter new.
	rewriter
		replace: '`var value'
			withValueFrom: [ :node | self inlineBlock: node for: aParser ]
			when: [ :node | (self instanceVariable: node receiver for: aParser) isBlock ];
		replace: '`var parseOn: aStream'
			withValueFrom: [ :node | self inlineParser: node for: aParser ]
			when: [ :node | (self instanceVariable: node receiver for: aParser) isPetitParser ];
		replace: '`var' 
			withValueFrom: [ :node | self inlineVariable: node for: aParser ].
	^ rewriter executeTree: aNode; answer! !

!PPJit methodsFor: 'private' stamp: 'lr 8/6/2010 16:56'!
instanceVariable: aNode for: aParser
	^ self instanceVariable: aNode for: aParser ifAbsent: [ nil ]! !

!PPJit methodsFor: 'private' stamp: 'lr 8/6/2010 16:56'!
instanceVariable: aNode for: aParser ifAbsent: aBlock
	| index |
	(aNode whoDefines: aNode name) notNil
		ifTrue: [ ^ aBlock value ].
	index := aParser class allInstVarNames
		indexOf: aNode name
		ifAbsent: [ ^ aBlock value ].
	^ aParser instVarAt: index! !

!PPJit methodsFor: 'configuration' stamp: 'lr 8/1/2010 08:52'!
parseOnSelector
	^ #parseOn:! !

!PPJit methodsFor: 'private' stamp: 'lr 8/2/2010 21:53'!
patchLiterals: aCompiledMethod
	| inverseMapping |
	inverseMapping := IdentityDictionary new: literalMapping size.
	literalMapping keysAndValuesDo: [ :key :value | inverseMapping at: value put: key ].
	2 to: aCompiledMethod numLiterals + 1 do: [ :index |
		aCompiledMethod objectAt: index put: (inverseMapping
			at: (aCompiledMethod objectAt: index)
			ifAbsent: [ aCompiledMethod objectAt: index ]) ].
	^ aCompiledMethod! !

!PPJit methodsFor: 'rewriting' stamp: 'lr 8/2/2010 17:33'!
rewrite: aNode using: aRewriter
	"Apply aRewriter repeatedly to aNode until no more changes can be performed."

	| tree |
	tree := aNode.
	[ aRewriter executeTree: tree ]
		whileTrue: [ tree := aRewriter tree ].
	^ tree! !

!PPJit methodsFor: 'rewriting' stamp: 'lr 8/2/2010 17:51'!
rewriteEmptyBlock
	| rewriter |
	rewriter := RBParseTreeRewriter new.
	rewriter
		replace: '[ ``.object ] value'
			with: '``.object'
			when: [ :aNode | aNode parent isCascade not ];
		replace: '| `@temps | ``@.Stmts1. [ | `@bTemps | ``@.bStmts ] value. ``@.Stmts2'
			with: '| `@temps `@bTemps | ``@.Stmts1. ``@.bStmts. ``@.Stmts2'.
	^ rewriter! !

!PPJit methodsFor: 'rewriting' stamp: 'lr 8/2/2010 17:51'!
rewriteEmtpyIfTrue
	| rewriter |
	rewriter := RBParseTreeRewriter new.
	rewriter
		replace: '``@boolean ifTrue: [ ] ifFalse: [ | `@temps | ``@.Stmts ]'
			with: '``@boolean ifFalse: [ |`@temps | ``@.Stmts ]';
		replace: '``@boolean ifFalse: [ ] ifTrue: [ | `@temps | ``@.Stmts ]'
			with: '``@boolean ifTrue: [ |`@temps | ``@.Stmts ]';
		replace: '``@boolean ifTrue: [ | `@temps | ``@.Stmts ] ifFalse: [ ]'
			with: '``@boolean ifTrue: [ |`@temps | ``@.Stmts ]';
		replace: '``@boolean ifFalse: [ | `@temps | ``@.Stmts ] ifTrue: [ ]'
			with: '``@boolean ifFalse: [ |`@temps | ``@.Stmts ]'.
	^ rewriter! !

!PPJit methodsFor: 'rewriting' stamp: 'lr 8/2/2010 17:33'!
rewriteGuardClause
	| rewriter |
	rewriter := RBParseTreeRewriter new.
	rewriter
		replaceMethod: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifTrue: [| `@t1 | `@.Stmts1. ^`@r1]. `@.s2. ^`@r2'
			with: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifTrue: [| `@t1 | `@.Stmts1. ^`@r1] ifFalse: [`@.s2. ^`@r2]';
		replaceMethod: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifFalse: [| `@t1 | `@.Stmts1. ^`@r1]. `@.s2. ^`@r2'
			with: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifTrue: [`@.s2. ^`@r2] ifFalse: [| `@t1 | `@.Stmts1. ^`@r1]';
		replaceMethod: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifTrue: [| `@t1 | `@.Stmts1. ^`@r1]. `@.s2'
			with: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifTrue: [| `@t1 | `@.Stmts1. ^`@r1] ifFalse: [`@.s2. ^self]';
		replaceMethod: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifFalse: [| `@t1 | `@.Stmts1. ^`@r1]. `@.s2'
			with: '`@methodName: `@args | `@temps | `@.s1. `@boolean ifTrue: [`@.s2. ^self] ifFalse: [| `@t1 | `@.Stmts1. ^`@r1]'.
	^ rewriter! !

!PPJit methodsFor: 'rewriting' stamp: 'lr 8/2/2010 17:32'!
rewriteIfTrue
	| rewriter |
	rewriter := RBParseTreeRewriter new.
	rewriter
		replace: '| `@temps | ``@.s1. ``@boolean ifTrue: [| `@t1 | ``@.Stmts1. ^`@r1]. ``@.s2. ^``@r2'
			with: '| `@temps | ``@.s1. ``@boolean ifTrue: [| `@t1 | ``@.Stmts1. ^`@r1] ifFalse: [``@.s2. ^``@r2]';
		replace: '| `@temps | ``@.s1. ``@boolean ifFalse: [| `@t1 | ``@.Stmts1. ^`@r1]. ``@.s2. ^``@r2'
			with: '| `@temps | ``@.s1. ``@boolean ifTrue: [``@.s2. ^``@r2] ifFalse: [| `@t1 | ``@.Stmts1. ^`@r1]'.
	^ rewriter! !

!PPJit methodsFor: 'rewriting' stamp: 'lr 8/2/2010 18:01'!
rewriteParserBlocks
	| rewriter |
	rewriter := RBParseTreeRewriter new.
	rewriter
		replace: '| `@temps1 | `@.stmts1. [ `collection size < 0 ] whileTrue: [ | `@temps2 | `@.stmts2 ]. `@.stmts3'
			with: '| `@temps1 | `@.stmts1. `@.stmts3';
		replace: '| `@temps1 | `@.stmts1. [ `collection size < 1 ] whileTrue: [ | `@temps2 | `@.stmts2 ]. `@.stmts3'
			with: '| `@temps1 `@temps2 | `@.stmts1. `@.stmts2. `@.stmts3';
		replace: '| `@temps1 | `@.stmts1. [ `collection size < 1073741823 ] whileTrue: [ | `@temps2 | `@.stmts2 ]. `@.stmts3'
			with: '| `@temps1 | `@.stmts1. [ | `@temps2 | `@.stmts2 ] repeat'.
	^ rewriter! !

!PPJit methodsFor: 'rewriting' stamp: 'lr 8/2/2010 17:32'!
rewriteReturns
	| rewriter |
	rewriter := RBParseTreeRewriter new.
	rewriter
		replace: '^``@boolean ifTrue: [| `@t1 | `@.Stmts1. ^``@r1] ifFalse: [| `@t2 | `@.Stmts2. ^``@r2]'
			with: '^``@boolean ifTrue: [| `@t1 | `@.Stmts1. ``@r1] ifFalse: [| `@t2 | `@.Stmts2. ``@r2]';
		replace: '^``@boolean ifFalse: [| `@t1 | `@.Stmts1. ^``@r1] ifTrue: [| `@t2 | `@.Stmts2. ^``@r2]'
			with: '^``@boolean ifFalse: [| `@t1 | `@.Stmts1. ``@r1] ifTrue: [| `@t2 | `@.Stmts2. ``@r2]';
		replace: '^``@boolean ifTrue: [| `@t1 | `@.Stmts1. ``@r1] ifFalse: [| `@t2 | `@.Stmts2. ^``@r2]'
			with: '^``@boolean ifTrue: [| `@t1 | `@.Stmts1. ``@r1] ifFalse: [| `@t2 | `@.Stmts2. ``@r2]';
		replace: '^``@boolean ifFalse: [| `@t1 | `@.Stmts1. ``@r1] ifTrue: [| `@t2 | `@.Stmts2. ^``@r2]'
			with: '^``@boolean ifFalse: [| `@t1 | `@.Stmts1. ``@r1] ifTrue: [| `@t2 | `@.Stmts2. ``@r2]';
		replace: '^``@boolean ifTrue: [| `@t1 | `@.Stmts1. ^``@r1] ifFalse: [| `@t2 | `@.Stmts2. ``@r2]'
			with: '^``@boolean ifTrue: [| `@t1 | `@.Stmts1. ``@r1] ifFalse: [| `@t2 | `@.Stmts2. ``@r2]';
		replace: '^``@boolean ifFalse: [| `@t1 | `@.Stmts1. ^``@r1] ifTrue: [| `@t2 | `@.Stmts2. ``@r2]'
			with: '^``@boolean ifFalse: [| `@t1 | `@.Stmts1. ``@r1] ifTrue: [| `@t2 | `@.Stmts2. ``@r2]';
		replace: '``@boolean ifTrue: [| `@t1 | `@.Stmts1. ^``@r1] ifFalse: [| `@t2 | `@.Stmts2. ^``@r2]'
			with: '^``@boolean ifTrue: [| `@t1 | `@.Stmts1. ``@r1] ifFalse: [| `@t2 | `@.Stmts2. ``@r2]';
		replace: '``@boolean ifFalse: [| `@t1 | `@.Stmts1. ^``@r1] ifTrue: [| `@t2 | `@.Stmts2. ^``@r2]'
			with: '^``@boolean ifFalse: [| `@t1 | `@.Stmts1. ``@r1] ifTrue: [| `@t2 | `@.Stmts2. ``@r2]'.
	^ rewriter! !

!PPJit methodsFor: 'configuration' stamp: 'lr 8/1/2010 08:52'!
rootParserClass
	^ PPParser! !

Object subclass: #PPOptimizer
	instanceVariableNames: 'rewriter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Optimizer'!

!PPOptimizer commentStamp: '<historical>' prior: 0!
PPOptimizer improves the internal structure of a grammar without touching its behavior.

Instance Variables:
	rewriter	<PPRewriter>	The rewriter that knows how to optimize a grammar.!

!PPOptimizer methodsFor: 'optimizations-choice' stamp: 'lr 8/26/2010 08:36'!
emptyChoice
	<optimize>

	rewriter
		replace: PPChoiceParser new
		with: PPFailingParser new! !

!PPOptimizer methodsFor: 'optimizations' stamp: 'lr 9/15/2010 13:53'!
foldDuplicates: aParser
	"Merges duplicated parsers into one single instance, what reduces the memory and enables many of the other optimizations to perform better. For efficiency reasons this optimization is implemented imperatively."

	| uniques |
	uniques := IdentitySet with: aParser.
	aParser allParsersDo: [ :parent |
		parent children do: [ :child |
			| duplicate |
			duplicate := uniques
				detect: [ :each | 
					child ~~ each
						and: [ child match: each inContext: Dictionary new ] ]
				ifNone: [ nil ].
			duplicate isNil
				ifTrue: [ uniques add: child ]
				ifFalse: [ parent replace: child with: duplicate ] ] ].
	^ aParser ! !

!PPOptimizer methodsFor: 'optimizations-delegate' stamp: 'lr 4/29/2010 21:41'!
identityWrapper
	<optimize>
	
	rewriter
		replace: (PPPattern kind: PPDelegateParser)
		withValueFrom: [ :parser | parser children first ]! !

!PPOptimizer methodsFor: 'optimizations-delegate' stamp: 'lr 8/26/2010 09:55'!
idepotentDelegate
	<optimize>
	
	rewriter
		replace: PPPattern any
		withValueFrom: [ :parser | parser children first ]
		when: [ :parser |
			parser children size = 1
				and: [ parser class = parser children first class
				and: [ #(PPAndParser PPEndOfInputParser PPFlattenParser PPTokenParser PPMemoizedParser PPTrimmingParser) includes: parser class name ] ] ]! !

!PPOptimizer methodsFor: 'initialization' stamp: 'lr 4/29/2010 21:01'!
initialize
	rewriter := PPRewriter new.
	(Pragma allNamed: #optimize in: self class)
		do: [ :each | self perform: each selector ]! !

!PPOptimizer methodsFor: 'optimizations-choice' stamp: 'lr 5/3/2010 21:50'!
nestedChoice
	<optimize>
	
	| before inside after |
	before := PPListPattern any.
	inside := PPListPattern any.
	after := PPListPattern any.
	rewriter
		replace: before / (PPChoiceParser with: inside) / after
		with: before / inside / after! !

!PPOptimizer methodsFor: 'optimizations-choice' stamp: 'lr 9/1/2010 22:07'!
nilledChoice
	<optimize>
	
	| before parser after |
	parser := PPPattern any.
	rewriter
		replace: parser / nil asParser
		with: parser optional! !

!PPOptimizer methodsFor: 'optimizations-choice' stamp: 'lr 9/1/2010 22:07'!
nulledChoice
	<optimize>
	
	| before parser after |
	before := PPListPattern any.
	parser := PPPattern any.
	after := PPListPattern any.
	rewriter
		replace: before / nil asParser / parser / after
		with: before / nil asParser! !

!PPOptimizer methodsFor: 'public' stamp: 'lr 9/15/2010 11:43'!
optimize: aParser
	"Transform aParser by applying all the matching optimization rules. Repeatedly apply the rules until no more changes can be done."
	
	| current |
	current := self foldDuplicates: aParser.
	[ current := rewriter execute: current.
	  rewriter hasChanged ]
			whileTrue.
	^ current! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 10:00'!
optionalChoice
	<optimize>

	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser optional / parser
		with: parser optional! !

!PPOptimizer methodsFor: 'optimizations-epsilon' stamp: 'lr 8/26/2010 09:39'!
optionalEpsilon
	<optimize>

	rewriter
		replace: nil asParser optional
		with: nil asParser! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 09:46'!
optionalOptional
	<optimize>
	
	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser optional optional
		with: parser optional! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 09:46'!
optionalPlus
	<optimize>

	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser optional plus
		with: parser star! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 10:02'!
optionalPlusChoice
	<optimize>

	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser optional / parser plus
		with: parser star! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 09:46'!
optionalStar
	<optimize>

	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser optional star
		with: parser star! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 10:02'!
optionalStarChoice
	<optimize>

	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser optional / parser star
		with: parser star! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 10:00'!
plusChoice
	<optimize>

	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser plus / parser
		with: parser plus! !

!PPOptimizer methodsFor: 'optimizations-epsilon' stamp: 'lr 8/26/2010 11:09'!
plusEpsilon
	<optimize>

	rewriter
		replace: nil asParser plus
		with: nil asParser! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 09:46'!
plusOptional
	<optimize>

	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser plus optional
		with: parser star! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 10:03'!
plusOptionalChoice
	<optimize>

	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser plus / parser optional
		with: parser star! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 09:46'!
plusPlus
	<optimize>
	
	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser plus plus
		with: parser plus! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 09:46'!
plusStar
	<optimize>
	
	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser plus star
		with: parser star! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 10:03'!
plusStarChoice
	<optimize>

	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser plus / parser star
		with: parser star! !

!PPOptimizer methodsFor: 'optimizations-choice' stamp: 'lr 4/29/2010 23:19'!
prefixedChoice
	<optimize>
	
	| before prefix body1 body2 postfix after |
	before := PPListPattern any.
	prefix := PPPattern any.
	body1 := PPListPattern any.
	body2 := PPListPattern any.
	postfix := PPPattern any.
	after := PPListPattern any.
	rewriter
		replace: before / (prefix , body1) / (prefix , body2) / after
		with: before / (prefix , (body1 / body2)) / after.
	rewriter
		replace: before / (body1 , postfix) / (body2 , postfix) / after
		with: before / ((body1 / body2) , postfix) / after! !

!PPOptimizer methodsFor: 'optimizations-choice' stamp: 'lr 4/29/2010 21:41'!
repeatedChoice
	<optimize>
	
	| before parser between after |
	before := PPListPattern any.
	parser := PPPattern any.
	between := PPListPattern any.
	after := PPListPattern any.
	rewriter
		replace: before / parser / between / parser / after
		with: before / parser / between / after! !

!PPOptimizer methodsFor: 'optimizations-choice' stamp: 'lr 5/3/2010 21:50'!
singleChoice
	<optimize>

	| parser |
	parser := PPPattern any.
	rewriter
		replace: (PPChoiceParser with: parser)
		with: parser! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 10:00'!
starChoice
	<optimize>

	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser star / parser
		with: parser star! !

!PPOptimizer methodsFor: 'optimizations-epsilon' stamp: 'lr 8/26/2010 11:09'!
starEpsilon
	<optimize>

	rewriter
		replace: nil asParser star
		with: nil asParser! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 09:47'!
starOptional
	<optimize>
	
	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser star optional
		with: parser star! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 10:03'!
starOptionalChoice
	<optimize>

	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser star / parser optional
		with: parser star! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 09:47'!
starPlus
	<optimize>
	
	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser star plus
		with: parser star! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 10:03'!
starPlusChoice
	<optimize>

	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser star / parser plus
		with: parser star! !

!PPOptimizer methodsFor: 'optimizations-operators' stamp: 'lr 8/26/2010 09:47'!
starStar
	<optimize>
	
	| parser |
	parser := PPPattern any.
	rewriter
		replace: parser star star
		with: parser star! !