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

"{ NameSpace: Smalltalk }"

PPCNodeVisitor subclass:#PPCCodeGenerator

	instanceVariableNames:'compiler'

	classVariableNames:''

	poolDictionaries:''

	category:'PetitCompiler-Visitors'

!

!PPCCodeGenerator class methodsFor:'as yet unclassified'!

new

    ^ self basicNew

        initialize;

        yourself 

!

on: aPPCCompiler

    ^ self new 

        compiler: aPPCCompiler;

        yourself

! !

!PPCCodeGenerator methodsFor:'accessing'!

compiler: aPPCCompiler

    compiler := aPPCCompiler 

!

guards

    ^ arguments guards

! !

!PPCCodeGenerator methodsFor:'code generation'!

generateChoiceChildOf: choiceNode atIndex: choiceChildNodeIndex useGuards: useGuards storeResultInto: resultVar

    | children |

    children := choiceNode children.

    useGuards ifTrue:[

        self addGuard: (children at: choiceChildNodeIndex) ifTrue: [ 

                    compiler add: 'self clearError.'.

                    compiler 

                          codeAssignParsedValueOf:[ self visit:(children at: choiceChildNodeIndex) ]

                          to: resultVar.

                    compiler add: 'error ifFalse: [ '.

                    compiler codeReturn: resultVar.  

                    compiler add: ' ].'.

                ] ifFalse:[ 

                    compiler add: 'error := true.'.

                ].

                compiler add: 'error ifTrue:[ '.

                choiceChildNodeIndex < children size ifTrue:[ 

                    self generateChoiceChildOf: choiceNode atIndex: choiceChildNodeIndex + 1 useGuards: useGuards storeResultInto: resultVar.

                ] ifFalse:[ 

                    compiler codeError: 'no choice suitable'.

                ].

                compiler addOnLine: '].'.

    ] ifFalse:[ 

                choiceChildNodeIndex <= children size ifTrue:[ 

                    compiler add: 'self clearError.'.

                    compiler 

                          codeAssignParsedValueOf:[ self visit:(children at: choiceChildNodeIndex) ]

                          to: resultVar.

                    compiler add: 'error ifFalse: [ '.

                    compiler codeReturn: resultVar.  

                    compiler add: ' ].'.

                    self generateChoiceChildOf: choiceNode atIndex: choiceChildNodeIndex + 1 useGuards: useGuards storeResultInto: resultVar.

                ] ifFalse:[ 

                    compiler codeError: 'no choice suitable'.

                ].

    ].

!

generateSequenceChildOf: sequenceNode atIndex: sequenceNodeChildIndex useMememntoVar: mementoVar storeResultInto: elementVars

        | child childValueVar |

        child := sequenceNode children at: sequenceNodeChildIndex.

        childValueVar := elementVars at: sequenceNodeChildIndex.

        compiler codeAssignParsedValueOf: [ self visit:child ] 

                                      to: childValueVar.

        child acceptsEpsilon ifFalse: [   

            compiler codeIfErrorThen: [

                "Handle error in the first element in a special way,

                 because one does not need to do backtracking  if the first element fails."

                (sequenceNodeChildIndex == 1) ifTrue: [                         

                    compiler codeReturn: 'failure'

                ] ifFalse: [

                    compiler smartRestore: sequenceNode from: mementoVar.

                    compiler codeReturn: 'failure.'.

                ]

            ] else:[ 

                sequenceNode returnParsedObjectsAsCollection ifTrue:[

                    compiler add: self retvalVar , ' at: ', sequenceNodeChildIndex asString, ' put: ', childValueVar, '.'.

                ].

                (sequenceNodeChildIndex < sequenceNode children size) ifTrue:[ 

                    self generateSequenceChildOf: sequenceNode atIndex: sequenceNodeChildIndex + 1 useMememntoVar: mementoVar storeResultInto: elementVars.

                ].

            ]

        ] ifTrue:[

            sequenceNode returnParsedObjectsAsCollection ifTrue:[

                compiler add: self retvalVar , ' at: ', sequenceNodeChildIndex asString, ' put: ', childValueVar, '.'.

            ].

            (sequenceNodeChildIndex < sequenceNode children size) ifTrue:[ 

                    self generateSequenceChildOf: sequenceNode atIndex: sequenceNodeChildIndex + 1 useMememntoVar: mementoVar storeResultInto: elementVars.

            ].

        ]

! !

!PPCCodeGenerator methodsFor:'guards'!

addGuard: node ifTrue: trueBlock ifFalse: falseBlock

    |  guard id |

    (self guards not or: [(guard := PPCGuard on: node) makesSense not]) ifTrue: [ ^ false].

    id := compiler idFor: node.

"	falseBlock isNil ifFalse: [ 

        compiler add: 'context atEnd'.

        compiler addOnLine: ' ifTrue: ['.

        compiler indent.

        falseBlock value.

        compiler dedent.

        compiler addOnLine: '].'.

    ]."

    guard id: (compiler idFor: guard prefixed: #guard).

    guard compileGuard: compiler.

    trueBlock isNil ifFalse: [ 

        compiler addOnLine: ' ifTrue: ['.

        compiler indent.

        trueBlock value.

        compiler dedent.

        falseBlock isNil 	ifTrue: [ compiler addOnLine: '].' ]

                              	ifFalse: [ compiler add: ']'. ]

    ].

    falseBlock isNil ifFalse: [ 

        compiler addOnLine: ' ifFalse: ['.

        compiler indent.

        falseBlock value.

        compiler dedent.

        compiler addOnLine: '].'.

    ].

    ^ true

!

addGuardTrimming: node

    |  guard firsts id |

    (self guards not or: [(guard := PPCGuard on: node) makesSense not]) ifTrue: [ ^ false].

    id := compiler idFor: node.

    firsts := node firstSetWithTokens.

    (firsts allSatisfy: [ :e | e isTrimmingTokenNode ]) ifTrue: [  

        "If we start with trimming, we should invoke the whitespace parser"

        self compileTokenWhitespace: firsts anyOne.

        ^ true

    ].

    ^ false

! !

!PPCCodeGenerator methodsFor:'hooks'!

afterAccept: node retval: retval

    "return the method from compiler"

    ^ self stopMethodForNode: node.

!

beforeAccept: node

    self startMethodForNode: node

!

closedDetected: node

    ^ node isMarkedForInline ifFalse: [ 

        self error: 'Should not happen!!'

    ]

!

openDetected: node

    ^ compiler checkCache: (compiler idFor: node)

! !

!PPCCodeGenerator methodsFor:'private'!

checkBlockIsInlinable: block

    "Check whether the given block could be inlined. If not, 

     throw an error. If yes, this method is noop.

     A block is inlineable if and only if it's a purely functional

     (see PPCASTUtilities>>checkBlockIsPurelyFunctional:inClass: for 

     details)

     As a side-effect, copy all self-sent methods from the block

     to the target class.          

    "

    | blockNode |

    blockNode := block sourceNode.

    "In Smalltalk implementation which use cheap-block optimization (Smalltalk/X) it may

     happen that home context of the block is nil (in case of cheap blocks)"

    block home notNil ifTrue:[ 

        | blockClass |

        blockClass := block home receiver class.

        PPCASTUtilities new checkNodeIsFunctional: blockNode inClass: blockClass.

        "The above code should raise an error when block is not functional (i.e., when not

         inlineable, so if the control flow reach this point, block is OK and we can safely 

         copy self-sent methods."

        self copySelfSentMethodsOf: blockNode inClass: blockClass

    ].

    "Created: / 27-07-2015 / 14:40:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 27-07-2015 / 15:52:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

copySelfSentMethodsOf: anRBProgramNode inClass: aClass

    PPCASTUtilities new withAllMessageNodesOf: anRBProgramNode sentToSelfDo: [ :node|

        | method source |

        method := aClass lookupSelector: node selector.

        method isNil ifTrue:[

            PPCCompilationError new signalWith: 'oops, no method found (internal error)!!'.        

        ].

        source := method source.

        source isNil ifTrue:[ 

            PPCCompilationError new signalWith: 'unavailable source for method ', method printString ,'!!'.        

        ].

        "Following actually copies the method to the target class,

         though the APU is not nice. This has to be cleaned up"

        (compiler cachedValue: node selector) isNil ifTrue:[ 

            compiler cache: node selector as: (PPCMethod new id: node selector; source: source; yourself).

            "Now compile self-sends of the just copied method"

            self copySelfSentMethodsOf: method parseTree inClass: aClass

        ].

    ]

    "Created: / 27-07-2015 / 14:50:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!PPCCodeGenerator methodsFor:'support'!

compileTokenWhitespace: node

    compiler add: 'context atWs ifFalse: ['.

    compiler indent.

        compiler 

              codeAssignParsedValueOf:[ self visit:node whitespace ]

              to:#whatever.

        compiler add: 'context setWs.'.

    compiler dedent.

    compiler add: '].'.

!

notCharSetPredicateBody: node

    | classificationId  classification |

    self error: 'deprecated.'.

    classification := node extendClassification: node predicate classification.

    classificationId := (compiler idFor: classification prefixed: #classification).

    compiler  addConstant: classification as: classificationId.

    compiler addOnLine: '(', classificationId, ' at: context peek asInteger)'.

    compiler indent.

    compiler add: ' ifTrue: [ self error: '' predicate not expected'' ]'.

    compiler add: ' ifFalse: [ nil ].'.

    compiler dedent.

!

notMessagePredicateBody: node

    self error: 'deprecated'.

    compiler addOnLine: '(context peek ', node message, ')'.

    compiler indent.

    compiler add: ' ifTrue: [ self error: '' predicate not expected'' ]'.

    compiler add: ' ifFalse: [ nil ].'.

    compiler dedent.

!

predicateBody: node

    | tmpId |

    self error:'deprecated'.

    tmpId := (compiler idFor: node predicate prefixed: #predicate).

    compiler addConstant: node predicate as: tmpId.

    compiler addOnLine: '(context atEnd not and: [ ', tmpId , ' value: context uncheckedPeek])'.

    compiler indent.

    compiler add: 'ifFalse: [ self error: ''predicate not found'' ]'.

    compiler add: 'ifTrue: [ context next ].'.

    compiler dedent.	

!

retvalVar

    ^ compiler currentReturnVariable

    "Modified: / 15-06-2015 / 18:20:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

startMethodForNode:node

    node isMarkedForInline ifTrue:[ 

        compiler startInline: (compiler idFor: node).

        compiler addComment: 'BEGIN inlined code of ' , node printString.

        compiler indent.

    ] ifFalse:[ 

        compiler startMethod: (compiler idFor: node).

        compiler addComment: 'GENERATED by ' , node printString.

        compiler allocateReturnVariable.

    ].

    "Created: / 23-04-2015 / 15:51:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 23-04-2015 / 19:13:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified (format): / 15-06-2015 / 18:03:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

stopMethodForNode:aPPCNode

    ^ aPPCNode isMarkedForInline ifTrue:[ 

		compiler dedent.

		compiler add: '"END inlined code of ' , aPPCNode printString , '"'.

		compiler stopInline.

    ] ifFalse:[ 

		compiler stopMethod

    ].

    "Created: / 23-04-2015 / 15:51:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 23-04-2015 / 18:35:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!PPCCodeGenerator methodsFor:'traversing - caching'!

cache: node value: retval

    "this is compiler thing, not mine"

!

cachedDetected: node

    ^ compiler checkCache: (compiler idFor: node)

!

isCached: node

    ^ (compiler checkCache: (compiler idFor: node)) isNil not

! !

!PPCCodeGenerator methodsFor:'visiting'!

visitActionNode: node

    | blockNode blockBody blockNodesVar blockNeedsCollection blockMatches childValueVars |

    self checkBlockIsInlinable: node block.

    blockNode := node block sourceNode copy.

    self assert: blockNode arguments size == 1.

    blockNodesVar := blockNode arguments first .

    blockBody := blockNode body.

    "Now, analyze block body, search for all references to

     block arg <barg> and check if in all cases it's used 

     in one of the following patterns:

        * <barg> first , <barg> second, ... , <barg> sixth

        * <barg> at: <integer constant>

     If so, then the block code can be inlined and the intermediate

     result collection need not to be created. Keep this information

     in temporary `blockNeedsCollection`. 

     During the analysis, remember all nodes that matches the pattern

     in a dictionary `blockMatches` mapping the node to actual temporary

     variable where the node is used. This will be later used for block's node

     rewriting"

    blockNeedsCollection := true.

    node child isSequenceNode ifTrue:[

        blockNeedsCollection := false.

        blockMatches := IdentityDictionary new."Must use IDENTITY dict as nodes have overwritten their #=!!!!!!"

        childValueVars := node child preferredChildrenVariableNames.

        PPCASTUtilities new withAllVariableNodesOf: blockBody do:[:variableNode| 

            variableNode name = blockNodesVar name ifTrue:[ 

                "Check if variable node matches..."

                variableNode parent isMessage ifTrue:[ 

                    | parent |

                    parent := variableNode parent.

                    "Check for <barg> at: <number>"

                    ((parent selector == #at:) and:[ parent arguments first isLiteralNumber ]) ifTrue:[ 

                        blockMatches at: parent put: (childValueVars at: parent arguments first value).

                    ] ifFalse:[ 

                        "Check for <barg> first / second / ..."

                        | i |

                        i := #(first second third fourth fifth sixth) indexOf: parent selector.

                        i ~~ 0 ifTrue:[ 

                            blockMatches at: parent put: (childValueVars at: i).

                        ] ifFalse:[ 

                            blockNeedsCollection := true.

                        ].

                    ].

                ] ifFalse:[ 

                    blockNeedsCollection := true.

                ].

            ].

        ].

    ].

    blockNeedsCollection ifTrue:[

        "Bad, we have to use the collection.

         Replace all references to blockNodeVar to retvalVar..."

        PPCASTUtilities new withAllVariableNodesOf: blockBody do:[:variableNode| 

            variableNode name = blockNodesVar name ifTrue:[ 

                variableNode name: self retvalVar.

            ].

        ].

    ] ifFalse:[ 

        "Good, can avoid intermediate collection.

         Replace references to collection with corresponding temporary variable"

        blockMatches keysAndValuesDo:[:matchingNode :childValueVar |

            matchingNode parent replaceNode: matchingNode withNode: (RBVariableNode named: childValueVar).

        ].

        node child returnParsedObjectsAsCollection: false. 

    ].

    "Block return value is return value of last statement.

     So if the method is not inline, make last statement a return.

        if the method is inline, make it assignment to retvalVar."

    blockBody statements notEmpty ifTrue:["Care for empty blocks - [:t | ] !!"

        compiler currentMethod isInline ifTrue:[ 

            |  assignment |

            assignment := RBAssignmentNode variable: (RBVariableNode named: self retvalVar) value:  blockBody statements last.

            blockBody replaceNode: blockBody statements last withNode: assignment.

        ] ifFalse:[  

            | return |

            return := RBReturnNode value: blockBody statements last.

            blockBody replaceNode: blockBody statements last withNode: return.

        ].

    ].

    compiler codeAssignParsedValueOf:[ self visit:node child ] to:self retvalVar.

    compiler codeIfErrorThen: [ 

        compiler codeReturn: 'failure'. 

    ] else: [

        compiler code: blockBody.    

    ]

    "Modified: / 27-07-2015 / 15:49:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

visitAndNode: node

    | mementoVar |

    mementoVar := compiler allocateTemporaryVariableNamed: 'memento'.

    compiler smartRemember: node child to: mementoVar.

    compiler 

          codeAssignParsedValueOf:[ self visit:node child ]

          to:self retvalVar.

    compiler smartRestore: node child from: mementoVar.

    compiler codeReturn.

    "Modified: / 23-04-2015 / 15:59:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

visitAnyNode: node

    compiler codeReturn: 'context next ifNil: [ error := true. ].'.

    "Modified: / 23-04-2015 / 20:52:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

visitCharSetPredicateNode: node

    | classification classificationId |

    classification := node extendClassification: node predicate classification.

    classificationId := compiler idFor: classification prefixed: #classification.

    compiler addConstant: classification as: classificationId.

    compiler add: '(', classificationId, ' at: context peek asInteger)'.

    compiler indent.

    compiler add: 'ifFalse: ['.

    compiler codeError: 'predicate not found'.

    compiler add: '] ifTrue: [ '.

    compiler codeReturn: 'context next'.

    compiler add: '].'.

    compiler dedent.

!

visitCharacterNode: node

    | chid |

    node character ppcPrintable ifTrue: [ 

        chid := node character storeString 

    ] ifFalse: [ 

        chid := compiler idFor: node character prefixed: #char.

        compiler addConstant: (Character value: node character asInteger) as: chid .

    ].