SystemOrganization addCategory: #'PetitBeta-Processor'! SystemOrganization addCategory: #'PetitBeta-JIT'! SystemOrganization addCategory: #'PetitBeta-Tests'! !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-Tests'! !PPOptimizerTest class methodsFor: 'accessing' stamp: 'lr 5/31/2010 18:50'! packageNamesUnderTest ^ #('PetitBeta')! ! !PPOptimizerTest methodsFor: 'utilities' stamp: 'lr 4/29/2010 23:21'! optimize: aParser ^ aParser optimize! ! !PPOptimizerTest methodsFor: 'running' stamp: 'lr 4/29/2010 23:20'! setUp super setUp. a := $a asParser. b := $b asParser. c := $c asParser! ! !PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 5/3/2010 21:49'! testEmptyChoice | grammar | grammar := self optimize: PPChoiceParser new. self assert: grammar class = PPEpsilonParser! ! !PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 4/28/2010 20:57'! testNestedChoice | grammar | grammar := self optimize: a / (b / c). self assert: grammar class = PPChoiceParser. self assert: grammar children size = 3. self assert: grammar children first class = PPLiteralObjectParser. self assert: grammar children last class = PPLiteralObjectParser. grammar := self optimize: (a / b) / c. self assert: grammar class = PPChoiceParser. self assert: grammar children size = 3. self assert: grammar children first class = PPLiteralObjectParser. self assert: grammar children last class = PPLiteralObjectParser! ! !PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 4/28/2010 20:57'! testNulledChoice | grammar | grammar := self optimize: a / nil asParser / b / c. self assert: grammar class = PPChoiceParser. self assert: grammar children size = 2. self assert: grammar children first class = PPLiteralObjectParser. self assert: grammar children last class = PPEpsilonParser. grammar := self optimize: a / b / nil asParser / c. self assert: grammar class = PPChoiceParser. self assert: grammar children size = 3. self assert: grammar children first class = PPLiteralObjectParser. self assert: grammar children last class = PPEpsilonParser. grammar := self optimize: a / b / c / nil asParser. self assert: grammar class = PPChoiceParser. self assert: grammar children size = 4. self assert: grammar children first class = PPLiteralObjectParser. self assert: grammar children last class = PPEpsilonParser ! ! !PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 4/29/2010 22:10'! testPostfixChoice | grammar | grammar := self optimize: (a , b) / (c , b). self assert: grammar class = PPSequenceParser. self assert: grammar children size = 2. self assert: grammar children first class = PPChoiceParser. self assert: grammar children first children size = 2. self assert: grammar children first children first literal = $a. self assert: grammar children first children last literal = $c. self assert: grammar children last literal = $b! ! !PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 4/29/2010 22:09'! testPrefixChoice | grammar | grammar := self optimize: (a , b) / (a , c). self assert: grammar class = PPSequenceParser. self assert: grammar children size = 2. self assert: grammar children first literal = $a. self assert: grammar children last class = PPChoiceParser. self assert: grammar children last children size = 2. self assert: grammar children last children first literal = $b. self assert: grammar children last children last literal = $c! ! !PPOptimizerTest methodsFor: 'testing-delegate' stamp: 'lr 4/19/2010 18:39'! testReduceDelegate | grammar | grammar := self optimize: (PPAndParser on: (PPAndParser on: a)). self assert: grammar class = PPAndParser. self assert: grammar children first class = PPLiteralObjectParser. grammar := self optimize: (PPNotParser on: (PPNotParser on: a)). self assert: grammar class = PPNotParser. self assert: grammar children first class = PPLiteralObjectParser. grammar := self optimize: (PPFlattenParser on: (PPFlattenParser on: a)). self assert: grammar class = PPFlattenParser. self assert: grammar children first class = PPLiteralObjectParser. grammar := self optimize: (PPTokenParser on: (PPTokenParser on: a)). self assert: grammar class = PPTokenParser. self assert: grammar children first class = PPLiteralObjectParser. grammar := self optimize: (PPMemoizedParser on: (PPMemoizedParser on: a)). self assert: grammar class = PPMemoizedParser. self assert: grammar children first class = PPLiteralObjectParser. grammar := self optimize: (PPTrimmingParser on: (PPTrimmingParser on: a)). self assert: grammar class = PPTrimmingParser. self assert: grammar children first class = PPLiteralObjectParser! ! !PPOptimizerTest methodsFor: 'testing-delegate' stamp: 'lr 4/28/2010 20:57'! testRemoveDelegate | grammar | grammar := self optimize: a wrapped. self assert: grammar class = PPLiteralObjectParser. grammar := self optimize: a wrapped wrapped. self assert: grammar class = PPLiteralObjectParser. grammar := self optimize: a wrapped / b wrapped wrapped. self assert: grammar class = PPChoiceParser. self assert: grammar children first class = PPLiteralObjectParser. self assert: grammar children last class = PPLiteralObjectParser! ! !PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 4/28/2010 20:57'! testRepeatedChoice | grammar | grammar := self optimize: a / a / b / c. self assert: grammar class = PPChoiceParser. self assert: grammar children size = 3. grammar := self optimize: a / b / a / a. self assert: grammar class = PPChoiceParser. self assert: grammar children size = 2. grammar := self optimize: a / a / a / a. self assert: grammar class = PPLiteralObjectParser! ! !PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 5/3/2010 21:50'! testSingleChoice | grammar | grammar := self optimize: (PPChoiceParser with: a). self assert: grammar class = PPLiteralObjectParser! ! Object subclass: #PPOptimizer instanceVariableNames: 'rewriter' classVariableNames: '' poolDictionaries: '' category: 'PetitBeta-Processor'! !PPOptimizer commentStamp: '' prior: 0! PPOptimizer improves the internal structure of a grammar without touching its behavior. Instance Variables: rewriter The rewriter that knows how to optimize a grammar.! !PPOptimizer methodsFor: 'optimizations-choice' stamp: 'lr 4/29/2010 21:40'! emptyChoice rewriter replace: PPChoiceParser new with: PPEpsilonParser new! ! !PPOptimizer methodsFor: 'optimizations' stamp: 'lr 4/29/2010 21:41'! identityWrapper rewriter replace: (PPPattern kind: PPDelegateParser) withValueFrom: [ :parser | parser children first ]! ! !PPOptimizer methodsFor: 'optimizations' stamp: 'lr 4/29/2010 21:41'! idepotentDelegate rewriter replace: PPPattern any withValueFrom: [ :parser | parser children first ] when: [ :parser | parser children size = 1 and: [ parser class = parser children first class and: [ #(PPAndParser PPNotParser 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 | 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 4/29/2010 21:40'! nulledChoice | before parser after | before := PPListPattern any. parser := PPPattern any. after := PPListPattern any. rewriter replace: before / PPEpsilonParser new / parser / after with: before / PPEpsilonParser new! ! !PPOptimizer methodsFor: 'public' stamp: 'lr 4/29/2010 21:29'! optimize: aParser "Transform aParser by applying all the matching optimization rules. Repeatedly apply the rules until no more changes can be done." | current | current := aParser. [ current := rewriter execute: current. rewriter hasChanged ] whileTrue. ^ current! ! !PPOptimizer methodsFor: 'optimizations-choice' stamp: 'lr 4/29/2010 23:19'! prefixedChoice | 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 | 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 | parser | parser := PPPattern any. rewriter replace: (PPChoiceParser with: parser) with: parser! ! PPDelegateParser subclass: #PPJitCompiler instanceVariableNames: 'templates optimizations' classVariableNames: '' poolDictionaries: '' category: 'PetitBeta-JIT'! !PPJitCompiler methodsFor: 'initialization' stamp: 'lr 8/1/2010 20:53'! initialize self initializeTemplates! ! !PPJitCompiler methodsFor: 'initialization' stamp: 'lr 8/1/2010 09:03'! initializeTemplates templates := IdentityDictionary new. self rootParserClass withAllSubclassesDo: [ :class | | tree | tree := (class lookupSelector: self parseOnSelector) parseTree. tree notNil ifTrue: [ templates at: class put: tree ] ]! ! !PPJitCompiler methodsFor: 'private' stamp: 'lr 8/1/2010 21:45'! inline: aParser in: aNode mapping: aDictionary | rewriter | rewriter := RBParseTreeRewriter new. rewriter replace: '`variable parseOn: aStream' withValueFrom: [ :node | self replaceParser: node parser: aParser mapping: aDictionary ]; replace: '`variable' withValueFrom: [ :node | self replaceVariable: node parser: aParser mapping: aDictionary ]. rewriter executeTree: aNode. ^ rewriter tree "^ RBParseTreeRewriter new replace: '`variable' withValueFrom: [ :node | self matchVariable: node for: aParser mapping: aDictionary ]; executeTree: template copy; tree"! ! !PPJitCompiler methodsFor: 'private' stamp: 'lr 8/1/2010 20:45'! methodFor: aParser mapping: aDictionary ^ self inline: aParser in: (templates at: aParser class ifAbsent: [ ^ nil ]) copy mapping: aDictionary! ! !PPJitCompiler methodsFor: 'private' stamp: 'lr 8/1/2010 21:43'! optimizationRewriter | 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! ! !PPJitCompiler methodsFor: 'public' stamp: 'lr 8/1/2010 21:43'! optimize: aParser "Try to optimize aParser. If no reasonable optimization can be performed return the original parser." | mapping tree method | mapping := IdentityDictionary new. tree := self methodFor: aParser mapping: mapping. tree isNil ifTrue: [ ^ aParser ]. tree := self optimizedParseTreeFor: tree. Transcript clear; show: tree formattedCode. method := self rootParserClass compilerClass new compile: tree formattedCode in: self rootParserClass classified: nil notifying: nil ifFail: [ ^ aParser ]. ^ PPJitParser on: aParser method: (self patchLiterals: method generate mapping: mapping)! ! !PPJitCompiler methodsFor: 'private' stamp: 'lr 8/1/2010 20:53'! optimizedParseTreeFor: aNode | tree rewriter | tree := aNode. rewriter := self optimizationRewriter. [ rewriter executeTree: tree ] whileTrue: [ tree := rewriter tree ]. ^ tree! ! !PPJitCompiler methodsFor: 'configuration' stamp: 'lr 8/1/2010 08:52'! parseOnSelector ^ #parseOn:! ! !PPJitCompiler methodsFor: 'private' stamp: 'lr 8/1/2010 17:06'! patchLiterals: aCompiledMethod mapping: aDictionary | name | 2 to: aCompiledMethod numLiterals + 1 do: [ :index | name := aCompiledMethod objectAt: index. (name isSymbol and: [ name beginsWith: '__' ]) ifTrue: [ aCompiledMethod objectAt: index put: (aDictionary keyAtValue: name) ] ]. ^ aCompiledMethod! ! !PPJitCompiler methodsFor: 'private' stamp: 'lr 8/1/2010 15:47'! referenceTo: anObject mapping: aDictionary ^ RBLiteralNode value: (aDictionary at: anObject ifAbsentPut: [ ('__ref' , aDictionary size asString) asSymbol ]) ! ! !PPJitCompiler methodsFor: 'private-replacing' stamp: 'lr 8/1/2010 21:53'! replaceParser: aNode parser: aParser mapping: aDictionary | index value tree | index := aParser class allInstVarNames indexOf: aNode receiver name ifAbsent: [ ^ aNode ]. value := aParser instVarAt: index. self assert: (value isKindOf: self rootParserClass). tree := self methodFor: value mapping: aDictionary. (tree notNil and: [ tree body temporaries isEmpty and: [ tree body statements size = 1 and: [ tree body statements first isReturn ] ] ]) ifTrue: [ ^ tree body statements first value ]. ^ aNode copy receiver: (self referenceTo: value mapping: aDictionary); yourself ! ! !PPJitCompiler methodsFor: 'private-replacing' stamp: 'lr 8/1/2010 21:51'! replaceVariable: aNode parser: aParser mapping: aDictionary | index value | aNode name = 'self' ifTrue: [ ^ self referenceTo: aParser mapping: aDictionary ]. index := aParser class allInstVarNames indexOf: aNode name ifAbsent: [ ^ aNode ]. value := aParser instVarAt: index. ^ value isLiteral ifTrue: [ RBLiteralNode value: value ] ifFalse: [ self referenceTo: value mapping: aDictionary ]! ! !PPJitCompiler methodsFor: 'configuration' stamp: 'lr 8/1/2010 08:52'! rootParserClass ^ PPParser! ! 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! !