Merged JK's version from Monticello
Name: PetitParser-JanKurs.260
Author: JanKurs
Time: 17-11-2014, 12:09:05.490 PM
UUID: 07411cef-ef69-40db-9d93-d4018a9b34ef
Name: PetitTests-JanKurs.65
Author: JanKurs
Time: 17-11-2014, 12:09:04.530 PM
UUID: f98d613f-f4ce-4e0e-a7e9-310ee7c7e7a6
Name: PetitSmalltalk-JanKurs.78
Author: JanKurs
Time: 14-11-2014, 05:05:07.765 PM
UUID: 3d68330d-44d5-46c3-9705-97f627b3edbc
Name: PetitCompiler-JanKurs.71
Author: JanKurs
Time: 18-11-2014, 09:48:35.425 AM
UUID: 06352c33-3c76-4382-8536-0cc48e225117
Name: PetitCompiler-Tests-JanKurs.21
Author: JanKurs
Time: 17-11-2014, 05:51:53.134 PM
UUID: 8d6c0799-14e7-4871-8d91-8b0f9886db83
Name: PetitCompiler-Benchmarks-JanKurs.2
Author: JanKurs
Time: 17-11-2014, 05:51:07.887 PM
UUID: d5e3a980-7871-487a-a232-e3ca93fc2483
"{ Package: 'stx:goodies/petitparser/compiler' }"
Object subclass:#PPCCompiler
instanceVariableNames:'compilerStack compiledParser cache inlining debug profile
currentMethod guards ids tokenMode rootNode'
classVariableNames:''
poolDictionaries:''
category:'PetitCompiler-Core'
!
!PPCCompiler class methodsFor:'instance creation'!
new
"return an initialized instance"
^ self basicNew initialize.
! !
!PPCCompiler methodsFor:'accessing'!
fastMode
^ tokenMode
!
inlining
^ inlining
!
inlining: value
inlining := value
!
parameters: associations
| key value |
associations do: [ :ass |
key := ass key.
value := ass value.
(key = #profile) ifTrue: [ profile := value ].
(key = #inline) ifTrue: [ inlining := value ].
(key = #guards) ifTrue: [ guards := value ].
]
!
profile
^ profile
!
profile: aBoolean
profile := aBoolean
!
rootNode
^ rootNode
! !
!PPCCompiler methodsFor:'cleaning'!
clean: class
" Transcript crShow: 'Cleaning time: ',
[
" self cleanGeneratedMethods: class.
self cleanInstVars: class.
self cleanParsers: class.
self cleanConstants: class.
" ] timeToRun asMilliSeconds asString, 'ms'."
!
cleanConstants: class
class constants removeAll.
!
cleanGeneratedMethods: class
((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
class methodsDo: [ :mthd |
mthd category = #generated ifTrue:[
class removeSelector: mthd selector.
]
]
] ifFalse: [
(class allSelectorsInProtocol: #generated) do: [ :selector |
class removeSelectorSilently: selector ].
]
!
cleanInstVars: class
class class instanceVariableNames: ''.
!
cleanParsers: class
class parsers removeAll.
! !
!PPCCompiler methodsFor:'code generation'!
add: string
currentMethod add: string.
!
addComment: string
currentMethod add: '"', string, '"'.
!
addConstant: value as: name
compiledParser addConstant: value as: name.
!
addOnLine: string
currentMethod addOnLine: string.
!
addVariable: name
currentMethod addVariable: name.
!
allowInline
currentMethod allowInline
!
cache: id as: value
cache at: id put: value.
!
cachedValue: id
^ cache at: id ifAbsent: [ nil ]
!
call: anotherMethod
currentMethod add: anotherMethod call.
!
callOnLine: anotherMethod
currentMethod addOnLine: anotherMethod call.
!
dedent
currentMethod dedent
!
indent
currentMethod indent
!
nl
currentMethod nl
!
smartRemember: parser
^ self smartRemember: parser to: #memento
!
smartRemember: parser to: variableName
parser isContextFree ifTrue: [
^ variableName, ' := context lwRemember.'.
].
^ variableName, ':= context remember.'
!
smartRestore: parser
^ self smartRestore: parser from: #memento
!
smartRestore: parser from: mementoName
parser isContextFree ifTrue: [
^ 'context lwRestore: ', mementoName, '.'.
].
^ 'context restore: ', mementoName, '.'.
!
startTokenMode
tokenMode := true
!
stopTokenMode
tokenMode := false
! !
!PPCCompiler methodsFor:'code generation - ids'!
idFor: object prefixed: prefix
^ self idFor: object prefixed: prefix effect: #none
!
idFor: object prefixed: prefix effect: effect
^ self idFor: object prefixed: prefix suffixed: '' effect: effect.
!
idFor: object prefixed: prefix suffixed: suffix effect: effect
| body id |
"Halt if: [ (object isKindOf: PPCNode) and: [object name = #smalltalk_ws ] ]."
" ((object isKindOf: PPCNode) and: [object name = #smalltalk_ws ]) ifTrue: [ Transcript crShow: 'st_ws' ].
"
^ ids at: object ifAbsentPut: [
((object isKindOf: PPCNode) and: [object name isNotNil]) ifTrue: [
"Halt if: [ object name = #smalltalk_ws ]."
" (object name = #smalltalk_ws) ifTrue: [Transcript crShow: 'NEW st_ws'].
"
id := (object name, suffix) asSymbol.
"Make sure, that the generated ID is uniqe!!"
((ids values select: [ :e | e = id ]) isEmpty) ifTrue: [ id ]
ifFalse: [
body := ids size asString.
(id, '_', body) asSymbol
]
] ifFalse: [
body := ids size asString.
(prefix asString, '_', body, suffix) asSymbol
]
]
! !
!PPCCompiler methodsFor:'code generation - support'!
checkCache: id
| method |
"Check if method is hand written"
method := compiledParser compiledMethodAt: id ifAbsent: [ nil ].
method ifNotNil: [ ^ PPCCompiledMethod new id: id; yourself ].
^ self cachedValue: id
!
pop
| retval |
retval := compilerStack pop.
compilerStack isEmpty ifFalse: [ currentMethod := compilerStack top ].
^ retval
"Modified: / 21-11-2014 / 12:27:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
push
compilerStack push: currentMethod.
(compilerStack size > 500 )ifTrue: [ self error: 'unless it is very complex grammar, there is an error somewhere' ]
"Modified: / 21-11-2014 / 12:27:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
startInline: id
| sender |
currentMethod := PPCInlinedMethod new.
currentMethod id: id.
currentMethod profile: self profile.
self push.
sender := thisContext sender receiver.
self addComment: 'START inlining by ', sender asString.
!
startMethod: id
| sender |
(cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].
currentMethod := PPCMethod new.
currentMethod id: id.
currentMethod profile: self profile.
self push.
self cache: id as: currentMethod.
sender := thisContext sender receiver.
self addComment: 'START of method generated by ', sender asString.
!
stopInline
| sender |
sender := thisContext sender receiver.
self addComment: 'STOP inlining by ', sender asString.
^ self pop.
!
stopMethod
| sender |
sender := thisContext sender receiver.
self addComment: 'END of method generated by ', sender asString.
self cache: currentMethod methodName as: currentMethod.
^ self pop.
!
top
^ compilerStack top
! !
!PPCCompiler methodsFor:'compiling'!
compile: aPPParser as: name
^ self compile: aPPParser as: name params: #()
!
compile: aPPParser as: name params: params
| parser |
parser := self copy: aPPParser.
parser := self toCompilerTree: parser.
parser := self optimize: parser params: params.
parser := self compileTree: parser as: name parser: aPPParser params: params.
^ parser
!
compileTree: compilerTree as: name parser: parser params: params
| |
params do: [ :p |
(p key = #guards) ifTrue: [ self guards: p value ].
].
((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
| rPackageOrganizer |
rPackageOrganizer := Smalltalk at: #RPackageOrganizer.
rPackageOrganizer notNil ifTrue:[
rPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'.
].
compiledParser := (Smalltalk at: name ifAbsent: [ nil ]).
compiledParser ifNil: [
PPCompiledParser subclass: name
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
category:'PetitCompiler-Generated'.
compiledParser := Smalltalk at: name.
] ifNotNil: [
self clean: compiledParser
].
] ifFalse: [
RPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'.
compiledParser := (Smalltalk at: name ifAbsent: [ nil ]).
compiledParser ifNil: [
PPCompiledParser subclass: name.
compiledParser := Smalltalk at: name.
compiledParser category: 'PetitCompiler-Generated'
] ifNotNil: [
self clean: compiledParser
].
].
compiledParser constants removeAll.
rootNode := compilerTree.
self precomputeFirstSets: rootNode.
self precomputeFollowSets: rootNode.
self precomputeFollowSetsWithTokens: rootNode.
self startMethod: #start.
self add: '^ '.
self callOnLine: (compilerTree compileWith: self).
self stopMethod.
self installVariablesAndMethods.
compiledParser referringParser: parser.
^ compiledParser
!
copy: parser
^ parser transform: [ :p | p copy ].
!
installMethods: class
cache keysAndValuesDo: [ :key :method |
class compileSilently: method code classified: 'generated'.
]
!
installVariables: class
| string |
string := class constants keys inject: '' into: [:r :e | r, ' ', e ].
PPCompiledParser subclass: class name instanceVariableNames: string classVariableNames: '' poolDictionaries: '' category: 'PetitCompiler-Generated'.
!
installVariablesAndMethods
"Updates the class and compile generated code"
| compiledParserClassName |
compiledParserClassName := compiledParser name.
self installVariables: compiledParser.
"Now we have to refetch the class again. The reason is, that
in (at least) Smalltalk/X modyfing a layout of a class results
in creating a new class rather than updating an old one and migrating
instances. Therefore, to install methods in in correct class, we have
to refetch new version from system dictionary. On Pharo it should not harm."
compiledParser := Smalltalk at: compiledParserClassName.
self installMethods: compiledParser.
!
optimize: parser params: params
| retval |
retval := parser optimizeTree: params.
retval checkTree.
^ retval
!
precomputeFirstSets: root
| firstSets |
firstSets := root firstSets.
root allNodesDo: [ :node |
node firstSet: (firstSets at: node).
]
!
precomputeFollowSets: root
| followSets |
followSets := root followSets.
root allNodesDo: [ :node |
node followSet: (followSets at: node).
]
!
precomputeFollowSetsWithTokens: root
| followSets |
followSets := root followSetsSuchThat: [:e | e isTerminal or: [ e isKindOf: PPCTrimmingTokenNode ]].
root allNodesDo: [ :node |
node followSetWithTokens: (followSets at: node).
]
!
toCompilerTree: parser
^ parser asCompilerTree
! !
!PPCCompiler methodsFor:'guard'!
addSequenceGuard: parser
| firsts guardSet guardSetId |
(self guards not or: [(guardSet := self guardCharSet: parser) isNil]) ifTrue: [ ^ self].
firsts := (parser firstSetSuchThat: [ :e | (e isKindOf: PPTokenParser) or: [ e isTerminal ] ]).
"If we start with PPTokenParser, we should invoke the whitespace parser"
(firsts allSatisfy: [ :e | e isKindOf: PPTokenParser ]) ifTrue: [
guardSetId := (self idFor: guardSet prefixed: #guard).
self addConstant: guardSet as: guardSetId.
self add: 'wsParser parseOn: context.'.
self add: 'context atEnd ifTrue: [ ^ self error ].'.
self add: '(', guardSetId, ' value: context peek) ifFalse: [ ^ self error ].'.
].
(firsts allSatisfy: [ :e | e isTerminal ]) ifTrue: [
guardSetId := (self idFor: guardSet prefixed: #guard).
self addConstant: guardSet as: guardSetId.
self add: 'context atEnd ifTrue: [ ^ self error ].'.
self add: '(', guardSetId, ' value: context peek) ifFalse: [ ^ self error ].'.
].
!
guardCharSet: parser
| fs charSet |
"No Guards fro trimming parser so far"
(parser firstSetSuchThat: [ :e | e isKindOf: PPCTrimNode ]) isEmpty ifFalse: [ ^ nil ].
"Makes no sense to do guard for epsilon parse"
(parser acceptsEpsilon) ifTrue: [ ^ nil ].
fs := parser firstSet.
fs do: [ :p |
"If we can accept epsilon guard does not make sense"
p isNullable ifTrue: [ ^ nil ].
].
charSet := PPCharSetPredicate on: [:char | fs anySatisfy: [:e | (e firstCharParser parse: char asString) isPetitFailure not ]].
^ charSet
!
guards
^ guards
!
guards: aBoolean
guards := aBoolean
! !
!PPCCompiler methodsFor:'initialization'!
initialize
super initialize.
compilerStack := Stack new.
cache := IdentityDictionary new.
ids := Dictionary new.
tokenMode := false.
inlining := true.
profile := false.
guards := true.
! !
!PPCCompiler class methodsFor:'documentation'!
version_HG
^ '$Changeset: <not expanded> $'
! !