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

"{ NameSpace: Smalltalk }"

PPCNodeVisitor subclass:#PPCCodeGenerator

	classVariableNames:''

	poolDictionaries:''

!

!PPCCodeGenerator class methodsFor:'as yet unclassified'!

new

    ^ self basicNew

        initialize;

        yourself 

!

on: aPPCCompiler

    ^ self new 

        compiler: aPPCCompiler;

        yourself

! !

!PPCCodeGenerator methodsFor:'accessing'!

!

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: [ 

                          to: resultVar.

                ] ifFalse:[ 

                ].

                ].

    ] ifFalse:[ 

                choiceChildNodeIndex <= children size ifTrue:[ 

                          to: resultVar.

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

                ] ifFalse:[ 

                ].

    ].

!

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

        | child childValueVar |

        child := sequenceNode children at: sequenceNodeChildIndex.

        childValueVar := elementVars at: sequenceNodeChildIndex.

                                      to: childValueVar.

        child acceptsEpsilon ifFalse: [   

                "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: [                         

                ] ifFalse: [

                ]

            ] else:[ 

                sequenceNode returnParsedObjectsAsCollection ifTrue:[

                ].

                (sequenceNodeChildIndex < sequenceNode children size) ifTrue:[ 

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

                ].

            ]

        ] ifTrue:[

            sequenceNode returnParsedObjectsAsCollection ifTrue:[

            ].

            (sequenceNodeChildIndex < sequenceNode children size) ifTrue:[ 

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

            ].

        ]

! !

!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

! !

!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 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"

            "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>"

!

withAllVariableNodesOf: anRBProgramNode do: aBlock

    "Enumerate all chilren of `anRBProgramNode` (including itself)

     and evaluate `aBlock` for each variable node.

     This is a replacement for Smalltalk/X's RBProgramNode>>variableNodesDo:

     which is not present in Pharo"

    anRBProgramNode isVariable ifTrue:[ 

        aBlock value: anRBProgramNode.

        ^ self.

    ].

    anRBProgramNode children do:[:each | 

        self withAllVariableNodesOf: each do: aBlock

    ].

    "Created: / 18-06-2015 / 22:02:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!PPCCodeGenerator methodsFor:'support'!

compileTokenWhitespace: node

              to:#whatever.

!

notCharSetPredicateBody: node

    | classificationId  classification |

    self error: 'deprecated.'.

    classification := node extendClassification: node predicate classification.

!

notMessagePredicateBody: node

    self error: 'deprecated'.

!

predicateBody: node

    | tmpId |

    self error:'deprecated'.

!

retvalVar

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

!

startMethodForNode:node

    node isMarkedForInline ifTrue:[ 

    ] ifFalse:[ 

    ].

    "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

    ] ifFalse:[ 

    ].

    "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

!

isCached: node

! !

!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 | ] !!"

            |  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.

        ].

    ].

    ] else: [

    ]

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

!

visitAndNode: node

    | mementoVar |

          to:self retvalVar.

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

!

visitAnyNode: node

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

!

visitCharSetPredicateNode: node

    | classification classificationId |

    classification := node extendClassification: node predicate classification.

!

visitCharacterNode: node

    | chid |

    node character ppcPrintable ifTrue: [ 

        chid := node character storeString 

    ] ifFalse: [ 

    ].

!

visitChild: child of: node

    |  |

    (self isOpen: child) ifTrue: [ 

        "already processing..."

        ^ nil

    ].

    ^ self visit: child.

!

visitChoiceNode: node

    |  whitespaceConsumed useGuards resultVar  |

    whitespaceConsumed := self addGuardTrimming: node.

    useGuards := whitespaceConsumed.