tal.tcl

Richard Suchenwirth 2013-12-03 - This page contains the file tal.tcl with my experiments on the Tcl Assembly Language TAL, and specifically the dis2asm converter and the TAL optimizer. It is included by Visual TAL. For convenience, I'll paste the file here after any non-trivial updates, but will not comment much.
#!/usr/bin/env tclkit
package require Tcl 8.6
# tal.tcl -- experiments with the Tcl Assembly Language


namespace path ::tcl::mathop
#interp alias {} asm    {} ::tcl::unsupported::assemble ;# worksn't
if {[info commands asm] eq ""} {
    namespace eval tcl::unsupported {namespace export assemble}
    namespace import tcl::unsupported::assemble
    rename assemble asm
    interp alias {} disasm {} ::tcl::unsupported::disassemble
    interp alias {} repr   {} ::tcl::unsupported::representation ;# unrelated, useful
}
proc aproc {name argl body args} {
    proc $name $argl $body
    set res [disasm proc $name]
    if {"-x" in $args} {
        set res [list proc $name $argl [list asm [dis2asm $res]]]
        if {"-o" in $args} {set res [optimize $res]}
        eval $res
    }
    return $res
}
proc dis2asm body {
    global slot
    array unset slot
    set fstart " push -1\n   store @p\n   pop"
    set fstep  "incrImm @p +1\n   load @l\n   load @p
   listIndex\n   store @i\n   pop
   load @l\n   listLength\n   lt    "
    set res  ""
    set wait ""
    set jumptargets {}
    set lines [split $body \n]
    foreach line $lines { ;#-- pass 1: collect jump targets
        if [regexp {\# pc (\d+)} $line -> pc] {lappend jumptargets $pc}
    }
    set lineno 0
    set needDone 0
    foreach line $lines { ;#-- pass 2: do the rest
        incr lineno
        set line [string trim $line]
        if {$line eq ""} continue
        
        set code ""
        if {[regexp {slot (\d+), (.+)} $line -> number descr]} {
            set slot($number) $descr
        } elseif {[regexp {data=.+loop=%v(\d+)} $line -> ptr]} {
            #got ptr, carry on
        } elseif {[regexp {it%v(\d+).+\[%v(\d+)\]} $line -> copy number]} {
            set loopvar [lindex $slot($number) end]
            if {$wait ne ""} {
                set map [list @p $ptr @i $loopvar @l $copy]
                set code [string map $map $fstart]
                append res "\n  $code ;# $wait"
                set wait ""
            }
        } elseif {[regexp {^ *\((\d+)\) (.+)} $line -> pc instr]} {
            if {$pc in $jumptargets} {append res "\n label L$pc;"}
            if {[regexp {(.+)#(.+)} $instr -> instr comment]} {
                set arg [list [lindex $comment end]]
                if [string match jump* $instr] {set arg L$arg}
            } else {set arg ""}
            set instr0 [normalize [lindex $instr 0]]
            switch -- $instr0 {
                concat - invokeStk - listIndexImm - reverse {
                    set arg [lindex $instr end]
                }
                incrImm   {set arg [list $arg [lindex $instr end]]}
            }
            set code "$instr0 $arg"
            switch -- $instr0 {
                beginCatch {
                    set catchend [findCatchEnd $lines $lineno]
                    lappend code L$catchend
                    lappend jumptargets $catchend
                }
                done          {
                    if {$lineno < [llength $lines]-2} {
                        set code "jump Done"
                        incr needDone
                    } else {set code ""}
                }
                startCommand  {set code ""}
                foreach_start {set wait $line; continue}
                foreach_step  {set code [string map $map $fstep]}
            }
            append res "\n   [format %-24s $code] ;# $line"
        }
    }
    if $needDone {append res "\n label Done;"}
    return $res\n
}
proc normalize instr {
    regsub {\d+$} $instr "" instr ;# strip off trailing length indicator
    set instr [string map {
        existScalar    exist
        #incr1Imm       incrImm  
        incrScalar1Imm incrImm
        incrScalar     incr
        lappendScalar  lappend
        loadScalar     load   
        nop            ""  
        storeScalar    store
        unsetScalar    unset
    } $instr]
    return $instr
}
proc optimize tal {
    set last  ""
    set last2 ""
    set lines [split $tal \n]
    for {set i 0} {$i < [llength $lines]} {incr i} {
        set instr [regexp -inline {[A-Za-z0-9_]+} [lindex $lines $i]]
        if {"$last $instr" eq "push pop"} {
            lset lines $i-1 #o[lindex $lines $i-1] ;# mark for deletion
            lset lines $i   #o[lindex $lines $i]
        } elseif {"$last $instr" eq "jump jump"} { ;# unreachable jump
            lset lines $i   #o[lindex $lines $i]
        }
        set last $instr
    }
    while 1 {
        set tmp {} ;# remove marked lines
        foreach line $lines {if ![string match #o* $line] {lappend tmp $line}}
        set lines $tmp
        set found 0
        for {set i 0} {$i < [llength $lines]} {incr i} {
            set instr [regexp -inline {[A-Za-z0-9_]+} [lindex $lines $i]]
            if {"$last2 $last $instr" eq "jump label jump"} {
                set oldTrg [string trimright [lindex $lines $i-1 1] ";"]
                set newTrg [lindex $lines $i   1]
                lset lines $i-1 #o[lindex $lines $i-1] ;# mark for deletion
                lset lines $i   #o[lindex $lines $i]
                set found 1
                break
            }
            set last2 $last
            set last  $instr
        }
        if $found {
            set tmp {} ;# remove marked lines
            foreach line $lines {
                if [regexp "jump.* $oldTrg " $line] {
                    set line [string map [list " $oldTrg " " $newTrg "] $line]
                }
                if ![string match #o* $line] {lappend tmp $line}
            }
            set lines $tmp
        } else break
    }
    return [join $lines \n]
}
proc findCatchEnd {lines lineno} {
    set pc ""
    for {set i $lineno} {$i < [llength $lines]} {incr i} {
        if {[regexp {\((\d+)\) endCatch} [lindex $lines $i] -> pc]} break
    }
    if {$pc eq ""} {error "could not find end of catch for line $lineno"}
    for {set i $lineno} {$i < [llength $lines]} {incr i} {
        if {[string match "*jump*pc $pc*" [lindex $lines $i]]} {
            if {[regexp {\((\d+)\)} [lindex $lines $i+1] -> pc2]} {
                return $pc2
            }
        }
    }
    error "could not find jump source for $pc"
}
set  masm_subs {"push $" "load " jumpgt "gt;jumpTrue"} ;#------------------------------------ small experiments with meta-assembly
proc masm code {uplevel 1 [list asm [string map $::masm_subs $code]]}
proc mgt {x y} {masm {
    load x;load y;jumpgt GT;push no;jump Done;
    label GT; push yes
    label Done
}}
#--------------------------------------------------------------------------------------------- TEST SUITE
foreach i {total failed} {set $i 0}
proc test {cmd -> expected} {
    incr ::total
    catch {uplevel 1 $cmd} res
    if {$res ne $expected} {
        puts "***** $cmd -> $res, expected $expected"
        incr ::failed
    }
}

test {aproc f x {incr x}; f 41} -> 42
test {aproc f x {incr x} -x; f 22} -> 23
test {aproc f x {incr x} -x -o; f 522} -> 523
test {aproc f x {incr x -1} -x -o; f 522} -> 521
test {aproc f x {set a($x) 1; array get a}; f foo} -> {foo 1}
test {aproc f x {set a(1) $x; array get a}; f foo} -> {1 foo}
test {aproc sum x {expr [join $x +]} -x; sum {3 4 5}} -> 12

test {asm {expr sqrt(9)}} -> 3.0

proc lempty lst {masm {push $lst;listLength;push 0;eq}}
test {lempty {}} -> 1
test {lempty a}  -> 0

test {mgt 1 2} -> no
test {mgt 4 3} -> yes


puts "total $total tests, failed $failed"
Category Example