compiler_peg_mecpu.tcl

Go to the documentation of this file.

/*  -*- tcl -*-*/
/* */
/*  Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>*/
/*  Parser Generator / Transformation - Compile grammar to ME cpu instructions.*/

/*  This package assumes to be used from within a PAGE plugin. It uses*/
/*  the API commands listed below. These are identical across the major*/
/*  types of PAGE plugins, allowing this package to be used in reader,*/
/*  transform, and writer plugins. It cannot be used in a configuration*/
/*  plugin, and this makes no sense either.*/
/* */
/*  To ensure that our assumption is ok we require the relevant pseudo*/
/*  package setup by the PAGE plugin management code.*/
/* */
/*  -----------------+--*/
/*  page_info        | Reporting to the user.*/
/*  page_warning     |*/
/*  page_error       |*/
/*  -----------------+--*/
/*  page_log_error   | Reporting of internals.*/
/*  page_log_warning |*/
/*  page_log_info    |*/
/*  -----------------+--*/

/*  ### ### ### ######### ######### #########*/
/*  Dumping the input grammar. But not as Tcl or other code. In PEG*/
/*  format again, pretty printing.*/

/*  ### ### ### ######### ######### #########*/
/*  Requisites*/

/*  @mdgen NODEP: page::plugin*/

package require page::plugin ; /*  S.a. pseudo-package.*/

package require grammar::me::cpu::gasm
package require textutil
package require struct::graph

package require page::analysis::peg::emodes
package require page::util::quote
package require page::util::peg

namespace ::page::compiler::peg::mecpu {
    /*  Get the peg char de/encoder commands.*/
    /*  (unquote, quote'tcl)*/

    namespace import ::page::util::quote::*
    namespace import ::page::util::peg::*


    namespace gas {
    namespace import ::grammar::me::cpu::gas::begin
    namespace import ::grammar::me::cpu::gas::done
    namespace import ::grammar::me::cpu::gas::lift
    namespace import ::grammar::me::cpu::gas::state
    namespace import ::grammar::me::cpu::gas::state!
    }
    namespace import ::grammar::me::cpu::gas::*
    rename begin  {}
    rename done   {}
    rename lift   {}
    rename state  {}
    rename state! {}
}

/*  ### ### ### ######### ######### #########*/
/*  Data structures for the generated code.*/

/*  All data is held in node attributes of the tree. Per node:*/
/** 
 *# asm - List of instructions implementing the node.
 */



/*  ### ### ### ######### ######### #########*/
/*  API*/

ret  ::page::compiler::peg::mecpu (type t) {
    # Resolve the mode hints. Every gen(X) having a value of 'maybe'
    # (or missing) is for the purposes of this code a 'yes'.

    if {![page::analysis::peg::emodes::compute $t]} {
    page_error "  Unable to generate a ME parser without accept/generate properties"
    return
    }

    foreach n [$t nodes] {
    if {![$t keyexists $n gen] || ([$t get $n gen] eq "maybe")} {
        $t set $n gen 1
    }
    if {![$t keyexists $n acc]} {$t set $n acc 1}
    }

    # Synthesize a program, then the assembly code.

    mecpu::Synth $t
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Internal. Helpers*/

ret  ::page::compiler::peg::mecpu::Synth (type t) {
    # Phase 2: Bottom-up, synthesized attributes

    # We use a global graph to capture instructions and their
    # relations. The graph is then converted into a linear list of
    # instructions, with proper labeling and jump instructions to
    # handle all non-linear control-flow.

    set g [struct::graph g]
    $t set root gas::called {}

    page_info "* Synthesize graph code"

    $t walk root -order post -type dfs n {
    SynthNode $n
    }

    status             $g  ;  gdump $g synth
    remove_unconnected $g  ;  gdump $g nounconnected
    remove_dead        $g  ;  gdump $g nodead
    denop              $g  ;  gdump $g nonops
    parcmerge          $g  ;  gdump $g parcmerge
    forwmerge          $g  ;  gdump $g fmerge
    backmerge          $g  ;  gdump $g bmerge
    status             $g  
    pathlengths        $g  ;  gdump $g pathlen
    jumps              $g  ;  gdump $g jumps
    status             $g
    symbols            $g $t

    set cc [2code $t $g]
    #write asm/mecode [join $cc \n]

    statistics $cc

    $t set root asm $cc
    $g destroy
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode (type n) {
    upvar 1 t t g g
    if {$n eq "root"} {
    set code Root
    } elseif {[$t keyexists $n symbol]} {
    set code Nonterminal
    } elseif {[$t keyexists $n op]} {
    set code [$t get $n op]
    } else {
    return -code error "PANIC. Bad node $n, cannot classify"
    }

    page_log_info "  [np $n] := ([linsert [$t children $n] 0 $code])"

    SynthNode/$code $n
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/Root (type n) {
    upvar 1 t t g g

    # Root is the grammar itself.

    set gstart [$t get root start]
    set gname  [$t get root name]

    if {$gstart eq ""} {
    page_error "  No start expression."
    return
    }

    gas::begin $g $n halt "<Start Expression> '$gname'"
    $g node set [Who entry] instruction .C
    $g node set [Who entry] START .

    Inline $t $gstart sexpr
    /At sexpr/exit/ok   ; /Ok   ; Jmp exit/return
    /At sexpr/exit/fail ; /Fail ; Jmp exit/return

    gas::done --> $t
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/Nonterminal (type n) {
    upvar 1 t t g g

    # This is the root of a definition.
    #
    # The text is a procedure wrapping the match code of its
    # expression into the required the nonterminal handling (caching
    # and such), plus the support code for the expression matcher.

    set sym      [$t get $n symbol]
    set label    [$t get $n label]
    set gen      [$t get $n gen]
    set mode     [$t get $n mode]

    set pe       [lindex [$t children $n] 0]
    set egen     [$t get $pe gen]

    # -> inc_restore -found-> NOP  gen:  -> ok -> ias_push -> RETURN
    #               /!found             \                  /
    #              /                     \-fail --------->/
    #             /               !gen: -> RETURN
    #            /
    #            \-> icl_push (-> ias_mark) -> (*) -> SV -> inc_save (-> ias_mrewind) -X
    #
    # X -ok----> ias_push -> ier_nonterminal
    #  \                  /
    #   \-fail ----------/

    # Poking into the generated instructions, converting the initial
    # .NOP into a .C'omment.

    set first [gas::begin $g $n !okfail "Nonterminal '$sym'"]
    $g node set [Who entry] instruction .C
    $g node set [Who entry] START .

    Cmd inc_restore $label ; /Label restore ; /Ok

    if {$gen} {
    Bra ; /Label @
    /Fail ; Nop          ; Exit
    /At @
    /Ok   ; Cmd ias_push ; Exit
    } else {
    Nop ; Exit
    }

    /At restore ; /Fail
    Cmd icl_push ; # Balanced by inc_save (XX)
    Cmd icl_push ; # Balanced by pop after ier_terminal

    if {$egen} {
    # [*] Needed for removal of SV's from stack after handling by
    # this symbol, only if expression actually generates an SV.

    Cmd ias_mark
    }

    Inline $t $pe subexpr ; /Ok   ; Nop ; /Label unified
    /At subexpr/exit/fail ; /Fail ; Jmp unified
    /At unified

    switch -exact -- $mode {
    value   {Cmd isv_nonterminal_reduce $label}
    match   {Cmd isv_nonterminal_range  $label}
    leaf    {Cmd isv_nonterminal_leaf   $label}
    discard {Cmd isv_clear}
    default {return -code error "Bad nonterminal mode \"$mode\""}
    }

    Cmd inc_save $label ; # Implied icl_pop (XX)

    if {$egen} {
    # See [*], this is the removal spoken about before.
    Cmd ias_mrewind
    }

    /Label hold

    if {$gen} {
    /Ok
    Cmd ias_push
    Nop           ; /Label merge
    /At hold ; /Fail ; Jmp merge
    /At merge
    }

    Cmd ier_nonterminal "Expected $label"
    Cmd icl_pop
    Exit

    gas::done --> $t
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/? (type n) {
    upvar 1 t t g g

    # The expression e? is equivalent to e/epsilon.
    # And like this it is compiled.

    set pe       [lindex [$t children $n] 0]

    gas::begin $g $n okfail ?

    # -> icl_push -> ier_push -> (*) -ok--> ier_merge/ok --> icl_pop -ok----------------> OK
    #                             \                                                    /
    #                              \-fail-> ier_merge/f ---> icl_rewind -> iok_ok -ok-/

    Cmd icl_push
    Cmd ier_push

    Inline $t $pe subexpr

    /Ok
    Cmd ier_merge
    Cmd icl_pop
    /Ok ; Exit

    /At subexpr/exit/fail ; /Fail
    Cmd ier_merge
    Cmd icl_rewind
    Cmd iok_ok
    /Ok ; Exit

    gas::done --> $t
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/* (type n) {
    upvar 1 t t g g

    # Kleene star is like a repeated ?

    # Note: Compilation as while loop, as done now
    # means that the parser has no information about
    # the intermediate structure of the input in his
    # cache.

    # Future: Create a helper symbol X and compile
    # the expression e = e'* as:
    #     e = X; X <- (e' X)?
    # with match data for X put into the cache. This
    # is not exactly equivalent, the structure of the
    # AST is different (right-nested tree instead of
    # a list). This however can be handled with a
    # special nonterminal mode to expand the current
    # SV on the stack.

    # Note 2: This is a transformation which can be
    # done on the grammar itself, before the actual
    # backend is let loose. This "strength reduction"
    # allows us to keep this code here.

    set pe       [lindex [$t children $n] 0]
    set egen     [$t get $pe gen]

    # Build instruction graph.

    #  /<---------------------------------------------------------------\
    #  \_                                                                \_
    # ---> icl_push -> ier_push -> (*) -ok--> ier_merge/ok --> icl_pop ->/
    #                               \
    #                                \-fail-> ier_merge/f ---> icl_rewind -> iok_ok -> OK

    gas::begin $g $n okfail *

    Cmd icl_push ; /Label header
    Cmd ier_push

    Inline $t $pe loop

    /Ok
    Cmd ier_merge
    Cmd icl_pop
    Jmp header ; /CloseLoop

    /At loop/exit/fail ; /Fail
    Cmd ier_merge
    Cmd icl_rewind
    Cmd iok_ok
    /Ok ; Exit

    gas::done --> $t
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/+ (type n) {
    upvar 1 t t g g

    # Positive Kleene star x+ is equivalent to x x*
    # This is how it is compiled. See also the notes
    # at the * above, they apply in essence here as
    # well, except that the transformat scheme is
    # slighty different:
    #
    # e = e'*  ==> e = X; X <- e' X?

    set pe [lindex [$t children $n] 0]

    # Build instruction graph.

    # icl_push -> ier_push -> (*) -fail-> ier_merge/fl -> icl_rewind -> FAIL
    #                          \
    #                           \--ok---> ier_merge/ok -> icl_pop ->\_
    #                                                               /
    #    /<--------------------------------------------------------/
    #   /
    #  /<---------------------------------------------------------------\
    #  \_                                                                \_
    #   -> icl_push -> ier_push -> (*) -ok--> ier_merge/ok --> icl_pop ->/
    #                               \
    #                                \-fail-> ier_merge/f ---> icl_rewind -> iok_ok -> OK

    gas::begin $g $n okfail +

    Cmd icl_push
    Cmd ier_push

    Inline $t $pe first
    /At first/exit/fail ; /Fail
    Cmd ier_merge
    Cmd icl_rewind
    /Fail ; Exit

    /At first/exit/ok ; /Ok
    Cmd ier_merge
    Cmd icl_pop

    # Loop copied from Kleene *, it is *

    Cmd icl_push ; /Label header
    Cmd ier_push

    # For the loop we create the sub-expression instruction graph a
    # second time. This is done by walking the subtree a second time
    # and constructing a completely new node set. The result is
    # imported under a new name.

    set save [gas::state]
    $t walk $pe -order post -type dfs n {SynthNode $n}
    gas::state! $save
    Inline $t $pe loop

    /Ok
    Cmd ier_merge
    Cmd icl_pop
    Jmp header ; /CloseLoop

    /At loop/exit/fail ; /Fail
    Cmd ier_merge
    Cmd icl_rewind
    Cmd iok_ok
    /Ok ; Exit

    gas::done --> $t
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode// (type n) {
    upvar 1 t t g g

    set args [$t children $n]

    if {![llength $args]} {
    error "PANIC. Empty choice."

    } elseif {[llength $args] == 1} {
    # A choice over one branch is no real choice. The code
    # generated for the child applies here as well.

    gas::lift $t $n <-- [lindex $args 0]
    return
    }

    # Choice over at least two branches.
    # Build instruction graph.

    # -> BRA
    #
    # BRA -> icl_push (-> ias_mark) -> ier_push -> (*) -ok -> ier_merge -> BRA'OK
    #                                              \-fail -> ier_merge (-> ias_mrewind) -> icl_rewind -> BRA'FAIL
    #
    # BRA'FAIL -> BRA
    # BRA'FAIL -> FAIL (last branch)
    #
    # BRA'OK -> icl_pop -> OK

    gas::begin $g $n okfail /

    /Clear
    Cmd icl_pop ; /Label BRA'OK ; /Ok ; Exit
    /At entry

    foreach pe $args {
    set egen [$t get $pe gen]

    # Note: We do not check for static match results. Doing so is
    # an optimization we can do earlier, directly on the tree.

    Cmd icl_push
    if {$egen} {Cmd ias_mark}

    Cmd ier_push
    Inline $t $pe subexpr

    /Ok
    Cmd ier_merge
    Jmp BRA'OK

    /At subexpr/exit/fail ; /Fail
    Cmd ier_merge
    if {$egen} {Cmd ias_mrewind}
    Cmd icl_rewind

    # Branch failed. Go to the next branch. Fail completely at
    # last branch.
    }

    /Fail ; Exit

    gas::done --> $t
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/x (type n) {
    upvar 1 t t g g

    set args [$t children $n]

    if {![llength $args]} {
    error "PANIC. Empty sequence."

    } elseif {[llength $args] == 1} {
    # A sequence of one element is no real sequence. The code
    # generated for the child applies here as well.

    gas::lift $t $n <-- [lindex $args 0]
    return
    }

    # Sequence of at least two elements.
    # Build instruction graph.

    # -> icl_push -> SEG
    #
    # SEG (-> ias_mark) -> ier_push -> (*) -ok -> ier_merge -> SEG'OK
    #                                  \-fail -> ier_merge -> SEG'FAIL
    #
    # SEG'OK -> SEG
    # SEG'OK -> icl_pop -> OK (last segment)
    #
    # SEG'FAIL (-> ias_mrewind) -> icl_rewind -> FAIL

    gas::begin $g $n okfail x

    /Clear
    Cmd icl_rewind ; /Label SEG'FAIL ; /Fail ; Exit

    /At entry
    Cmd icl_push

    set gen 0
    foreach pe $args {
    set egen [$t get $pe gen]
    if {$egen && !$gen} {
        set gen 1

        # From here on out is the sequence able to generate
        # semantic values which have to be canceled when
        # backtracking.

        Cmd ias_mark ; /Label @mark

        /Clear
        Cmd ias_mrewind ; Jmp SEG'FAIL ; /Label SEG'FAIL

        /At @mark
    }

    Cmd ier_push
    Inline $t $pe subexpr

    /At subexpr/exit/fail ; /Fail
    Cmd ier_merge
    Jmp SEG'FAIL

    /At subexpr/exit/ok ; /Ok
    Cmd ier_merge 
    }

    Cmd icl_pop
    /Ok ; Exit

    gas::done --> $t
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/& (type n) {
    upvar 1 t t g g
    SynthLookahead $n no
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/! (type n) {
    upvar 1 t t g g
    SynthLookahead $n yes
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/dot (type n) {
    upvar 1 t t g g
    SynthTerminal $n {} "any character"
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/epsilon (type n) {
    upvar 1 t t g g

    gas::begin $g $n okfail epsilon

    Cmd iok_ok ; /Ok ; Exit

    gas::done --> $t
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/alnum (type n) {
    upvar 1 t t g g
    SynthClass $n alnum
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/alpha (type n) {
    upvar 1 t t g g
    SynthClass $n alpha
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/digit (type n) {
    upvar 1 t t g g
    SynthClass $n digit
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/xdigit (type n) {
    upvar 1 t t g g
    SynthClass $n xdigit
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/punct (type n) {
    upvar 1 t t g g
    SynthClass $n punct
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/space (type n) {
    upvar 1 t t g g
    SynthClass $n space
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/.. (type n) {
    upvar 1 t t g g
    # Range is [x-y]

    set b [$t get $n begin]
    set e [$t get $n end]

    set tb [quote'tcl $b]
    set te [quote'tcl $e]

    set pb [quote'tclstr $b]
    set pe [quote'tclstr $e]

    SynthTerminal $n [list ict_match_tokrange $tb $te] "\\\[${pb}..${pe}\\\]"
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/t (type n) {
    upvar 1 t t g g

    # Terminal node. Primitive matching.
    # Code is parameterized by gen(X) of this node X.

    set ch  [$t get $n char]
    set tch [quote'tcl    $ch]
    set pch [quote'tclstr $ch]

    SynthTerminal $n [list ict_match_token $tch] $pch
    return
}

ret  ::page::compiler::peg::mecpu::SynthNode/n (type n) {
    upvar 1 t t g g

    # Nonterminal node. Primitive matching.
    # The code is parameterized by acc(X) of this node X, and gen(D)
    # of the invoked nonterminal D.

    set sym   [$t get $n sym]
    set def   [$t get $n def]

    gas::begin $g $n okfail call'$sym'

    if {$def eq ""} {
    # Invokation of an undefined nonterminal. This will always fail.

    Note "Match for undefined symbol '$sym'"
    Cmdd iok_fail ; /Fail ; Exit
    gas::done --> $t

    } else {
    # Combinations
    # Acc Gen Action
    # --- --- ------
    #   0   0 Plain match
    #   0   1 Match with canceling of the semantic value.
    #   1   0 Plain match
    #   1   1 Plain match
    # --- --- ------

    if {[$t get $n acc] || ![$t get $def gen]} {
        Cmd icf_ntcall sym_$sym ; /Label CALL
        /Ok   ; Exit
        /Fail ; Exit

    } else {
        Cmd ias_mark
        Cmd icf_ntcall sym_$sym ; /Label CALL
        Cmd ias_mrewind
        /Ok   ; Exit
        /Fail ; Exit
    }

    set caller [Who CALL]
    gas::done --> $t

    $t lappend $def gas::callers $caller
    $t lappend root gas::called  $def
    }

    return
}

ret  ::page::compiler::peg::mecpu::SynthLookahead (type n , type negated) {
    upvar 1 g g t t

    # Note: Per the rules about expression modes (! is a lookahead
    # ____| operator) this node has a mode of 'discard', and its child
    # ____| has so as well.

    # assert t get n  mode == discard
    # assert t get pe mode == discard

    set op       [$t get $n op]
    set pe       [lindex [$t children $n] 0]
    set eop      [$t get $pe op]

    # -> icl_push -> (*) -ok--> icl_rewind -> OK
    #                 \--fail-> icl_rewind -> FAIL

    # -> icl_push -> (*) -ok--> icl_rewind -> iok_negate -> FAIL
    #                 \--fail-> icl_rewind -> iok_negate -> OK

    gas::begin $g $n okfail [expr {$negated ? "!" : "&"}]

    Cmd icl_push
    Inline $t $pe subexpr

    /Ok
    Cmd icl_rewind
    if {$negated} { Cmd iok_negate ; /Fail } else /Ok ; Exit

    /At subexpr/exit/fail ; /Fail
    Cmd icl_rewind
    if {$negated} { Cmd iok_negate ; /Ok } else /Fail ; Exit

    gas::done --> $t
    return
}

ret  ::page::compiler::peg::mecpu::SynthClass (type n , type op) {
    upvar 1 t t g g
    SynthTerminal $n [list ict_match_tokclass $op] <$op>
    return
}

ret  ::page::compiler::peg::mecpu::SynthTerminal (type n , type cmd , type msg) {
    upvar 1 t t g g

    # 4 cases (+/- cmd, +/- sv).
    #
    # (A) +cmd+sv
    #     entry -> advance -ok-> match -ok-> sv -> OK
    #              \             \
    #               \             \-fail----------> FAIL
    #                \-fail----------------------/
    #
    # (B) -cmd+sv
    #     entry -> advance -ok-> sv -> OK
    #              \
    #               \-fail-----------> FAIL
    #
    # (C) +cmd-sv
    #     entry -> advance -ok-> match -ok-> OK
    #              \             \
    #               \             \-fail---> FAIL
    #                \-fail---------------/
    #
    # (D) -cmd-sv
    #     entry -> advance -ok-> OK
    #              \
    #               \-fail-----> FAIL

    gas::begin $g $n okfail M'[lindex $cmd 0]

    Cmd ict_advance "Expected $msg (got EOF)"
    /Fail ; Exit
    /Ok

    if {[llength $cmd]} {
    lappend cmd "Expected $msg"
    eval [linsert $cmd 0 Cmd]
    /Fail ; Exit
    /Ok
    }

    if {[$t get $n gen]} {
    Cmd isv_terminal
    /Ok
    }

    Exit

    gas::done --> $t
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Internal. Extending the graph of instructions (expression*/
/*  framework, new instructions, (un)conditional sequencing).*/

/*  ### ### ### ######### ######### #########*/
/*  Internal. Working on the graph of instructions.*/

ret  ::page::compiler::peg::mecpu::2code (type t , type g) {
    page_info "* Generating ME assembler code"

    set insn  {}
    set start [$t get root gas::entry]
    set cat 0
    set calls [list $start]

    while {$cat < [llength $calls]} {
    set  now [lindex $calls $cat]
    incr cat

    set at 0
    set pending [list $now]

    while {$at < [llength $pending]} {
        set  current [lindex $pending $at]
        incr at

        while {$current ne ""} {
        if {[$g node keyexists $current WRITTEN]} break

        insn $g $current insn
        $g node set $current WRITTEN .

        if {[$g node keyexists $current SAVE]} {
            lappend pending [$g node get $current SAVE]
        }
        if {[$g node keyexists $current CALL]} {
            lappend calls [$g node get $current CALL]
        }

        set  current [$g node get $current NEXT]
        if {$current eq ""} break
        if {[$g node keyexists $current WRITTEN]} {
            lappend insn [list {} icf_jalways \
                [$g node get $current LABEL]]
            break
        }

        # Process the following instruction,
        # if there is any.
        }
    }
    }

    return $insn
}

ret  ::page::compiler::peg::mecpu::insn (type g , type current , type iv) {
    upvar 1 $iv insn

    set code [$g node get $current instruction]
    set args [$g node get $current arguments]

    set label {}
    if {[$g node keyexists $current LABEL]} {
    set label [$g node get $current LABEL]
    }

    lappend insn [linsert $args 0 $label $code]
    return
}

if 0 {
    if {[lindex $ins 0] eq "icf_ntcall"} {
     tmp =  {}
    foreach b $branches {
        if {[$g node keyexists $b START]} {
         sym =  [$g node get $b symbol]
        lappend ins     sym_$sym
        } else {
        lappend tmp $b
        }
    }
     branches =  $tmp
    }
}

/*  ### ### ### ######### ######### #########*/
/*  Optimizations.*/
/* */
/*  I. Remove all nodes which are not connected to anything.*/
/*     There should be none.*/

ret  ::page::compiler::peg::mecpu::remove_unconnected (type g) {
    page_info "* Remove unconnected instructions"

    foreach n [$g nodes] {
    if {[$g node degree $n] == 0} {
        page_error "$n ([printinsn $g $n])"
        page_error "Found unconnected node. This should not have happened."
        page_error "Removing the bad node."

        $g node delete $n
    }
    }
}

ret  ::page::compiler::peg::mecpu::remove_dead (type g) {
    page_info "* Remove dead instructions"

    set count 0
    set runs 0
    set hasdead 1
    while {$hasdead} {
    set hasdead 0
    foreach n [$g nodes] {
        if {[$g node keyexists $n START]} continue
        if {[$g node degree -in $n] > 0}  continue

        page_log_info "    [np $n] removed, dead ([printinsn $g $n])"

        $g node delete $n

        set hasdead 1
        incr count
    }
    incr runs
    }

    page_info "  Removed [plural $count instruction] in [plural $runs run]"
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Optimizations.*/
/* */
/*  II. We have lots of .NOP instructions in the control flow, as part*/
/*      of the framework. They made the handling of expressions easier,*/
/*      providing clear and fixed anchor nodes to connect to from*/
/*      inside and outside, but are rather like the epsilon-transitions*/
/*      in a (D,N)FA. Now is the time to get rid of them.*/
/* */
/*      We keep the .C'omments, and explicit .BRA'nches.*/
/*      We should not have any .NOP which is a dead-end (without*/
/*      successor), nor should we find .NOPs with more than one*/
/*      successor. The latter should have been .BRA'nches. Both*/
/*      situations are reported on. Dead-ends we*/
/*      remove. Multi-destination NOPs we keep.*/
/* */
/*      Without the nops in place to confus the flow we can perform a*/
/*      series peep-hole optimizations to merge/split branches.*/

ret  ::page::compiler::peg::mecpu::denop (type g) {
    # Remove the .NOPs and reroute control flow. We keep the pseudo
    # instructions for comments (.C) and the explicit branch points
    # (.BRA).

    page_info "* Removing the helper .NOP instructions."

    set count 0
    foreach n [$g nodes] {
    # Skip over nodes already deleted by a previous iteration.
    if {[$g node get $n instruction] ne ".NOP"} continue

    # We keep branching .NOPs, and warn user. There shouldn't be
    # any. such should explicit bnrachpoints.

    set destinations [$g arcs -out $n]

    if {[llength $destinations] > 1} {
        page_error "$n ([printinsn $g $n])"
        page_error "Found a .NOP with more than one destination."
        page_error "This should have been a .BRA instruction."
        page_error "Not removed. Internal error. Fix the transformation."
        continue
    }

    # Nops without a destination, dead-end's are not wanted. They
    # should not exist either too. We will do a general dead-end
    # and dead-start removal as well.

    if {[llength $destinations] < 1} {
        page_error "$n ([printinsn $g $n])"
        page_error "Found a .NOP without any destination, i.e. a dead end."
        page_error "This should not have happened. Removed the node."

        $g node delete $n
        continue
    }

    page_log_info "    [np $n] removed, updated cflow ([printinsn $g $n])"

    # As there is exactly one destination we can now reroute all
    # incoming arcs around the nop to the new destination.

    set target [$g arc target [lindex $destinations 0]]
    foreach a [$g arcs -in $n] {
        $g arc move-target $a $target
    }

    $g node delete $n
    incr count
    }

    page_info "  Removed [plural $count instruction]"
    return
}


/*  ### ### ### ######### ######### #########*/
/*  Optimizations.*/
/* */

/*  Merge parallel arcs (remove one, make the other unconditional).*/

ret  ::page::compiler::peg::mecpu::parcmerge (type g) {
    page_info "* Search for identical parallel arcs and merge them"

    #puts [join  [info loaded] \n] /seg.fault induced with tcllibc! - tree!

    set count 0
    foreach n [$g nodes] {
    set arcs [$g arcs -out $n]

    if {[llength $arcs] < 2} continue
    if {[llength $arcs] > 2} {
        page_error "  $n ([printinsn $g $n])"
        page_error "  Instruction has more than two destinations."
        page_error "  That is not possible. Internal error."
        continue
    }
    # Two way branch. Both targets the same ?

    foreach {a b} $arcs break

    if {[$g arc target $a] ne [$g arc target $b]} continue

    page_log_info "    [np $n] outbound arcs merged ([printinsn $g $n])"

    $g arc set $a condition always
    $g arc delete $b

    incr count 2
    }

    page_info "  Merged [plural $count arc]"
    return
}

/*  Use knowledge of the match status before and after an instruction to*/
/*  label the arcs a bit better (This may guide the forward and backward*/
/*  merging.).*/

/*  Forward merging of instructions.*/
/*  An ok/fail decision is done as late as possible.*/
/* */
/*   /- ok ---> Y -> U               /- ok ---> U*/
/*  X                    ==>   X -> Y*/
/*   \- fail -> Y -> V               \- fail -> V*/

/*  The Y must not have additional inputs. This more complex case we*/
/*  will look at later.*/

ret  ::page::compiler::peg::mecpu::forwmerge (type g) {
    page_info "* Forward merging of identical instructions"
    page_info "  Delaying decisions"
    set count 0
    set runs 0

    set merged 1
    while {$merged} {
    set merged 0
    foreach n [$g nodes] {
        # Skip nodes already killed in previous rounds.
        if {![$g node exists $n]} continue

        set outbound [$g arcs -out $n]
        if {[llength $outbound] != 2} continue

        foreach {aa ab} $outbound break
        set na [$g arc target $aa]
        set nb [$g arc target $ab]

        set ia [$g node get $na instruction][$g node get $na arguments]
        set ib [$g node get $nb instruction][$g node get $nb arguments]
        if {$ia ne $ib} continue

        # Additional condition: Inbounds in the targets not > 1

        if {([$g node degree -in $na] > 1) ||
        ([$g node degree -in $nb] > 1)} continue

        page_log_info "    /Merge [np $n] : [np $na] <- [np $nb] ([printinsn $g $na])"

        # Label all arcs out of na with the condition of the arc
        # into it.  Ditto for the arcs out of nb. The latter also
        # get na as their new origin. The arcs out of n relabeled
        # to always. The nb is deleted. This creates the desired
        # control structure without having to create a new node
        # and filling it. We simply use na, discard nb, and
        # properly rewrite the arcs to have the correct
        # conditions.

        foreach a [$g arcs -out $na] {
        $g arc set $a condition [$g arc get $aa condition]
        }
        foreach a [$g arcs -out $nb] {
        $g arc set $a condition [$g arc get $ab condition]
        $g arc move-source $a $na
        }
        $g arc set     $aa condition always
        $g node delete $nb
        set merged 1
        incr count
    }
    incr runs
    }

    # NOTE: This may require a parallel arc merge, with identification
    #       of merge-able arcs based on the arc condition, i.e. labeling.

    page_info "  Merged [plural $count instruction] in [plural $runs run]"
    return
}

/*  Backward merging of instructions.*/
/*  Common backends are put together.*/
/* */
/*  U -> Y ->\             U ->\*/
/*            -> X   ==>        -> Y -> X*/
/*  V -> Y ->/             V ->/*/

/*  Note. It is possible for an instruction to be amenable to both for-*/
/*  and backward merging. No heuristics are known to decide which is*/
/*  better.*/

ret  ::page::compiler::peg::mecpu::backmerge (type g) {
    page_info "* Backward merging of identical instructions"
    page_info "  Unifying paths"
    set count 0
    set runs 0

    set merged 1
    while {$merged} {
    set merged 0
    foreach n [$g nodes] {
        # Skip nodes already killed in previous rounds.
        if {![$g node exists $n]} continue

        set inbound [$g arcs -in $n]
        if {[llength $inbound] < 2} continue

        # We have more than 1 inbound arcs on this node. Check all
        # pairs of pre-decessors for possible unification.

        # Additional condition: Outbounds in the targets not > 1
        # We check in different levels, to avoid redundant calls.

        while {[llength $inbound] > 2} {
        set aa   [lindex $inbound 0]
        set tail [lrange $inbound 1 end]

        set na [$g arc source $aa]
        if {[$g node degree -out $na] > 1} {
            set inbound $tail
            continue
        }

        set inbound {}
        foreach ab $tail {
            set nb [$g arc source $ab]
            if {[$g node degree -out $nb] > 1} continue

            set ia [$g node get $na instruction][$g node get $na arguments]
            set ib [$g node get $nb instruction][$g node get $nb arguments]

            if {$ia ne $ib} {
            lappend inbound $ab
            continue
            }

            page_log_info "    \\Merge [np $n] : [np $na] <- [np $nb] ([printinsn $g $na])"

            # Discard the second node in the pair. Move all
            # arcs inbound into it so that they reach the
            # first node instead.

            foreach a [$g arcs -in $nb] {$g arc move-target $a $na}
            $g node delete $nb
            set merged 1
            incr count
        }
        }
    }
    incr runs
    }

    page_info "  Merged [plural $count instruction] in [plural $runs run]"
    return
}

/*  ### ### ### ######### ######### #########*/

ret  ::page::compiler::peg::mecpu::pathlengths (type g) {
    page_info "* Find maximum length paths"

    set pending [llength [$g nodes]]

    set nodes {}
    set loops {}
    foreach n [$g nodes] {
    $g node set $n WAIT [$g node degree -out $n]
    set insn [$g node get $n instruction]
    if {($insn eq "icf_halt") || ($insn eq "icf_ntreturn")} {
        lappend nodes $n
    }
    if {[$g node keyexists $n LOOP]} {
        lappend loops $n
    }
    }

    set level 0
    while {[llength $nodes]} {
    incr pending -[llength $nodes]
    set nodes [closure $g $nodes $level]
    incr level
    }

    if {[llength $loops]} {
    page_info "  Loop levels"

    set nodes $loops
    while {[llength $nodes]} {
        incr pending -[llength $nodes]
        set nodes [closure $g $nodes $level]
        incr level
    }
    }

    if {$pending} {
    page_info  "  Remainder"

    while {$pending} {
        set nodes {}
        foreach n [$g nodes] {
        if {[$g node keyexists $n LEVEL]} continue
        if {[$g node get $n WAIT] < [$g node degree -out $n]} {
            lappend nodes $n
        }
        }
        while {[llength $nodes]} {
        incr pending -[llength $nodes]
        set nodes [closure $g $nodes $level]
        incr level
        }
    }
    }
    return
}

ret  ::page::compiler::peg::mecpu::closure (type g , type nodes , type level) {
    page_log_info "  \[[format %6d $level]\] : $nodes"

    foreach n $nodes {$g node set $n LEVEL $level}

    set tmp {}
    foreach n $nodes {
    foreach pre [$g nodes -in $n] {
        # Ignore instructions already given a level.
        if {[$g node keyexists $pre LEVEL]} continue
        $g node set $pre WAIT [expr {[$g node get $pre WAIT] - 1}]
        if {[$g node get $pre WAIT] > 0} continue
        lappend tmp $pre
    }
    }
    return [lsort -uniq -dict $tmp]
}

ret  ::page::compiler::peg::mecpu::jumps (type g) {
    page_info "* Insert explicit jumps and branches"

    foreach n [$g nodes] {
    # Inbound > 1, at least one is from a jump, so a label is
    # needed.

    if {[llength [$g arcs -in $n]] > 1} {
        set go bra[string range $n 4 end]
        $g node set $n LABEL $go
    }

    set darcs [$g arcs -out $n]

    if {[llength $darcs] == 0} {
        $g node set $n NEXT ""
        continue
    }

    if {[llength $darcs] == 1} {
        set da [lindex $darcs 0]
        set dn [$g arc target $da]

        if {[$g node get $dn LEVEL] > [$g node get $n LEVEL]} {
        # Flow is backward, an uncond. jump
        # is needed here.

        set go bra[string range $dn 4 end]
        $g node set $dn LABEL $go
        set j [$g node insert]
        $g arc move-target $da $j
        $g node set $j instruction icf_jalways
        $g node set $j arguments   $go

        $g arc insert $j $dn

        $g node set $n NEXT $j
        $g node set $j NEXT ""
        } else {
        $g node set $n NEXT $dn
        }
        continue
    }

    set aok {}
    set afl {}
    foreach a $darcs {
        if {[$g arc get $a condition] eq "ok"} {
        set aok $a
        } else {
        set afl $a
        }
    }
    set nok [$g arc target $aok]
    set nfl [$g arc target $afl]

    if {[$g node get $n instruction] eq "inc_restore"} {
        set go bra[string range $nok 4 end]
        $g node set $nok LABEL $go

        $g node set $n NEXT $nfl
        $g node set $n SAVE $nok

        $g node set $n arguments [linsert [$g node get $n arguments] 0 $go]
        continue
    }

    if {[$g node get $n instruction] ne ".BRA"} {
        set bra [$g node insert]
        $g arc move-source $aok $bra
        $g arc move-source $afl $bra
        $g arc insert $n $bra
        $g node set $n NEXT $bra
        set n $bra
    }

    if {[$g node get $nok LEVEL] > [$g node get $nfl LEVEL]} {
        # Ok branch is direct, Fail is jump.

        $g node set $n NEXT $nok
        $g node set $n SAVE $nfl

        set go bra[string range $nfl 4 end]
        $g node set $nfl LABEL $go
        $g node set $n instruction icf_jfail
        $g node set $n arguments   $go
    } else {

        # Fail branch is direct, Ok is jump.

        $g node set $n NEXT $nfl
        $g node set $n SAVE $nok

        set go bra[string range $nok 4 end]
        $g node set $nok LABEL $go
        $g node set $n instruction icf_jok
        $g node set $n arguments   $go
    }
    }
}

ret  ::page::compiler::peg::mecpu::symbols (type g , type t) {
    page_info "* Label subroutine heads"

    # Label and mark the instructions where subroutines begin.
    # These markers are used by 2code to locate all actually
    # used subroutines.

    foreach def [lsort -uniq [$t get root gas::called]] {
    set gdef [$t get $def gas::entry]
    foreach caller [$t get $def gas::callers] {

        # Skip callers which are gone because of optimizations.
        if {![$g node exists $caller]} continue

        $g node set $caller CALL $gdef
        $g node set $gdef LABEL \
            [lindex [$g node set $caller arguments] 0]
    }
    }
    return
}

/*  ### ### ### ######### ######### #########*/

ret  ::page::compiler::peg::mecpu::statistics (type code) {
    return
    # disabled
    page_info "* Statistics"
    statistics_si $code

    # All higher order statistics are done only on the instructions in
    # a basic block, i.e. a linear sequence. We are looking for
    # high-probability blocks in itself, and then also for
    # high-probability partials.

    set blocks [basicblocks $code]

    # Basic basic block statistics (full blocks)

    Init bl
    foreach b $blocks {Incr bl($b)}
    wrstat  bl asm/statistics_bb.txt
    wrstatk bl asm/statistics_bbk.txt

    # Statistics of all partial blocks, i.e. all possible
    # sub-sequences with length > 1.

    Init ps
    foreach b $blocks {
    for {set s 0} {$s < [llength $b]} {incr s} {
        for {set e [expr {$s + 1}]} {$e < [llength $b]} {incr e} {
        Incr ps([lrange $b $s $e]) $bl($b)
        }
    }
    }

    wrstat  ps asm/statistics_ps.txt
    wrstatk ps asm/statistics_psk.txt
    return
}

ret  ::page::compiler::peg::mecpu::statistics_si (type code) {
    page_info "  Single instruction probabilities."

    # What are the most used instructions, statically speaking,
    # without considering context ?

    Init si
    foreach i $code {
    foreach {label name} $i break
    if {$name eq ".C"} continue
    Incr si($name)
    }

    wrstat si asm/statistics_si.txt
    return
}

ret  ::page::compiler::peg::mecpu::Init (type v) {
    upvar 1 $v var total total
    array set var {}
    set total 0
    return
}

ret  ::page::compiler::peg::mecpu::Incr (type v , optional n =1) {
    upvar 1 $v var total total
    if {![info exists var]} {set var $n ; incr total ; return}
    incr var $n
    incr total $n
    return
}

ret  ::page::compiler::peg::mecpu::wrstat (type bv , type file) {
    upvar 1 $bv buckets total total

    set tmp  {}
    foreach {name count} [array get buckets] {
    lappend tmp [list $name $count]
    }

    set     lines {}
    lappend lines "Total: $total"

    set half [expr {$total / 2}]
    set down $total

    foreach item [lsort -index 1 -decreasing -integer [lsort -index 0 $tmp]] {
    foreach {key count} $item break

    set percent [format %6.2f [expr {$count*100.0/$total}]]%
    set fcount  [format %8d $count]

    lappend lines "  $fcount $percent $key"
    incr down -$count
    if {$half && ($down < $half)} {
        lappend lines **
        set half 0
    }
    }

    write $file [join $lines \n]\n
    return
}

ret  ::page::compiler::peg::mecpu::wrstatk (type bv , type file) {
    upvar 1 $bv buckets total total

    set tmp  {}
    foreach {name count} [array get buckets] {
    lappend tmp [list $name $count]
    }

    set     lines {}
    lappend lines "Total: $total"

    set half [expr {$total / 2}]
    set down $total

    foreach item  [lsort -index 0 [lsort -index 1 -decreasing -integer $tmp]] {
    foreach {key count} $item break

    set percent [format %6.2f [expr {$count*100.0/$total}]]%
    set fcount  [format %8d $count]

    lappend lines "  $fcount $percent $key"
    incr down -$count
    if {$down < $half} {
        lappend lines **
        set half -1
    }
    }

    write $file [join $lines \n]\n
    return
}

ret  ::page::compiler::peg::mecpu::basicblocks (type code) {
    set blocks {}
    set block {}

    foreach i $code {
    foreach {label name} $i break
    if {
        ($name eq ".C")          ||
        ($name eq "icf_jok")     ||
        ($name eq "icf_jfail")   ||
        ($name eq "icf_jalways") ||
        ($name eq "icf_ntreturn")
    } {
        # Jumps stop a block, and are not put into the block
        # Except if the block is of length 1. Then it is of
        # interest to see if certain combinations are used
        # often.

        if {[llength $block]} {
        if {[llength $block] == 1} {lappend block $name}
        lappend blocks $block
        }
        set block {}
        continue
    } elseif {$label ne ""} {
        # A labeled instruction starts a new block and belongs to
        # it. Note that the previous block is saved only if it is
        # of length > 1. A single instruction block is not
        # something we can optimize.

        if {[llength $block] > 1} {lappend blocks $block}
        set block [list $name]
        continue
    }
    # Extend current block
    lappend block $name
    }

    if {[llength $block]} {lappend blocks $block}
    return $blocks
}

/*  ### ### ### ######### ######### #########*/

ret  ::page::compiler::peg::mecpu::printinsn (type g , type n) {
    return "[$g node get $n instruction] <[$g node get $n arguments]>"
}

ret  ::page::compiler::peg::mecpu::plural (type n , type prefix) {
    return "$n ${prefix}[expr {$n == 1 ? "" : "s"}]"
}

ret  ::page::compiler::peg::mecpu::np (type n) {
    format %-*s 8 $n
}

ret  ::page::compiler::peg::mecpu::status (type g) {
    page_info "[plural [llength [$g nodes]] instruction]"
    return
}

ret  ::page::compiler::peg::mecpu::gdump (type g , type file) {
    return
    # disabled
    variable gnext
    page_info "  %% Saving graph to \"$file\" %%"
    write asm/[format %02d $gnext]_${file}.sgr [$g serialize]
    incr gnext
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Internal. Strings.*/

namespace ::page::compiler::peg::mecpu {
    variable gnext 0
}

/*  ### ### ### ######### ######### #########*/
/*  Ready*/

package provide page::compiler::peg::mecpu 0.1.1