view keiko/iset.tcl @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
line wrap: on
line source
#
# iset.tcl
# 
# This file is part of the Oxford Oberon-2 compiler
# Copyright (c) 2006--2016 J. M. Spivey
# All rights reserved
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# 1. Redistributions of source code must retain the above copyright notice,
#    this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright notice,
#    this list of conditions and the following disclaimer in the documentation
#    and/or other materials provided with the distribution.
# 3. The name of the author may not be used to endorse or promote products
#    derived from this software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
# IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
# OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
# ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#

# This workaround is needed with TCL 8.4.2 if output goes to an emacs
# compilation buffer.
fconfigure stdout -translation lf
fconfigure stderr -translation lf

if {[llength $argv] != 4} {
    puts stderr "usage: iset input.iset header template interp"
    exit 1
}

set srcdir [file dirname $argv0]
source "$srcdir/util.tcl"
source "$srcdir/iparse.tcl"

if {[file exists "config.tcl"]} {source "config.tcl"}

lsplit $argv infile hfile tfile ifile

# BUILD THE TRIE

# make_trie -- recursively build a trie for a set of strings
proc make_trie {n strings} {
    global charcode first trie taken check ntrie

    # Assume the strings agree on the first n characters

    if {[llength $strings] == 0} {
        puts stderr "Empty trie!!!"
        return -9999
    }

    # Set chars to the set of n'th characters of the strings
    set chars [remdups [lsort [map {nth_char $n} $strings]]]
    set c1 $charcode([lindex $chars 0])

    # Find a place where a node for $chars will fit -- 0 for the root
    for {set q 0} {1} {incr q} {
        if {[info exists taken($q)]} continue

        while {$ntrie <= $q+128} {
            set trie($ntrie) 0
            set check($ntrie) 128
            incr ntrie
        }

        set ok 1
        foreach c $chars {
            set ix [expr {$q+$charcode($c)}]
            if {$check($ix) != 128} {
                set ok 0; break
            }
        }

        if {$ok} break
    }

    # Reserve the locations we will use by filling in check
    # (actual values in trie get filled in later)
    set taken($q) 1

    foreach c $chars {
        set ix [expr {$q+$charcode($c)}]
        set check($ix) $charcode($c)
    }

    # Recursively build sub-tries
    foreach c $chars {
        if {$c == ""} {
            set t [string range [lindex $strings 0] 0 [expr {$n-1}]]
            set trie($q) $first($t)
            set check($q) 0
        } else {
            set ix [expr {$q+$charcode($c)}]
            set subset [filter {nth_char_is $n $c} $strings]
            set trie($ix) [make_trie [expr {$n+1}] $subset]
            set check($ix) $charcode($c)
        }
    }

    return $q
}

proc has_templates {i} {
    global templates
    return [expr {[llength $templates($i)] > 0}]
}

# Build a packed trie for the instructions
proc build_trie {} {
    global ntrie instrs dirs
    set ntrie 0
    make_trie 0 [filter has_templates [concat $instrs $dirs]]
}

proc dmp_trie {f q pfx} {
    global trie check ntrie

    set sep ""
    if {$check($q) == 0} {
        puts $f [format "--> %d" $trie($q)]
        set sep $pfx
    }
    set nchild 0
    for {set c 1} {$c < 128} {incr c} {
        set i [expr {$q+$c}]
        if {$check($i) == $c} {
            set char($nchild) $c
            set son($nchild) $trie($i)
            incr nchild
        }
    }

    for {set j 0} {$j < $nchild} {incr j} {
        puts -nonewline $f [format "%s\[%c\] %3d " $sep $char($j) $son($j)]
        if {$j+1 < $nchild} {
            set slug " |      "
        } else {
            set slug "        "
        }
        dmp_trie $f $son($j) "$pfx$slug"
        set sep $pfx
    }
}
        

# GENERATE HEADER FILE

proc gen_header {name} {
    global ntempl maxargs instrs instrno dirs dirno ops action ntrie \
        expand opcode ncodes

    set f [open $name "w"]
    puts $f "/* Header file -- generated by iset.tcl */"
    puts $f ""
    puts $f "#define NTEMPLATES $ntempl"
    puts $f "#define NTRIE $ntrie"
    puts $f "#define MAXARGS $maxargs"
    puts $f ""

    puts $f "#define __INSTRS__(i) \\"
    puts -nonewline $f "     i(ILLEGAL)"
    foreach i $instrs {
        set m [list [csym "" $i]]
        if {[info exists expand($i)]} {
            foreach x $expand($i) {
                if {[regexp {^(.*) \$a$} $x _ y]} {
                    lappend m "[csym I $y]|IARG"
                } elseif {[regexp {^(.*) (-?[0-9]*)$} $x _ y z]} {
                    lappend m "[csym I $y]|ICON" $z
                } else {
                    lappend m "[csym I $x]"
                }
            }
        }
        puts -nonewline $f \
            " \\\n     i([join $m ", "])"
    }
    puts $f ""
    puts $f ""
    puts $f "#define __i1__(sym, ...) I_##sym,"
    puts $f "enum { __INSTRS__(__i1__) };"
    puts $f ""

    puts $f "#define __DIRS__(d) \\"
    puts -nonewline $f "     d(ILLEGAL)"
    foreach d $dirs {
        puts -nonewline $f " \\\n     d([csym "" $d])"
    }
    puts $f ""
    puts $f ""
    puts $f "#define __d1__(sym) D_##sym,"
    puts $f "enum { __DIRS__(__d1__) };"
    puts $f ""

    # Not an enum, because bases are not contiguous!
    puts $f "#define K_ILLEGAL 0"
    foreach op $ops {
        with $action($op) {base count length inst key act args} {
            puts $f "#define [csym K $op] $base"
        }
    }
    puts $f ""

    puts -nonewline $f "#define __OPCODES__(o)"
    for {set i 0} {$i < $ncodes} {incr i} {
        with $opcode($i) {op inst patt arg len} {
            puts -nonewline $f \
                " \\\n     o($op, $inst, \"$patt\", $arg, $len)"
        }
    }
    puts $f ""

    close $f
}

# GENERATE TEMPLATE FILE

# make_code -- assemble equivalent code
proc make_code {op} {
    global ops dirs status

    if {$op == "NOP"} {
        return {}
    } elseif {[lmember $op $ops]} {
        return [csym K $op]
    } elseif {[lmember $op $dirs]} {
        return [csym D $op]
    } else {
        puts stderr "Code $op does not exist"
        set status 1
    }
}

proc quote {s} {return "\"$s\""}

proc gen_template {name} {
    global templates instrs dirs first ntrie trie check macro

    set f [open $name "w"]
    puts $f "/* Template file -- generated by iset.tcl */"
    puts $f ""
    puts $f "#include \"oblink.h\""
    puts $f "#include \"keiko.h\""
    puts $f ""

    set nt 0
    set fmt "{%-12s %-7s%3d, %2d, %2d, %2d, %2d, %s, {%s}},"
    puts $f "struct _template templates\[NTEMPLATES\] = {"
    foreach inst [concat $instrs $dirs] {
        set first($inst) $nt
        foreach templ $templates($inst) {
            with $templ {patt bounds op argsz} {
                with $bounds {lo hi step} {
                    if {$nt == $first($inst)} {
                        set icode "\"$inst\""
                    } else {
                        set icode "   NULL"
                    }
                    if {[info exists macro($op)]} {
                        set maclines [map quote $macro($op)]
                        puts $f \
                            [format $fmt "$icode," "\"$patt\"," \
                                 $lo $hi $step 0 0 0 [join $maclines ", "]]
                    } else {
                        if {$op == "NOP"} {
                            set n 0; set c 0
                        } else {
                            set n 1; set c [make_code $op]
                        }
                        set len [expr {$argsz >= 0 ? $n + $argsz : $argsz}]
                        puts $f \
                            [format $fmt "$icode," "\"$patt\"," \
                                 $lo $hi $step  $len $n $c ""]
                    }
                }
            }
            incr nt
        }
    }
    puts $f "};";
    puts $f "";

    build_trie

    puts $f "/*"
    dmp_trie $f 0 ""
    puts $f "*/"
    puts $f ""

    puts $f "short templ_trie\[NTRIE\] = {"
    for {set i 0} {$i < $ntrie} {incr i} {
        if {$i > 0 && $i % 10 == 0} {puts $f ""}
        puts -nonewline $f [format "%4d, " $trie($i)]
    }
    puts $f "\n};"    
    puts $f "";
    puts $f "uchar templ_check\[NTRIE\] = {"
    for {set i 0} {$i < $ntrie} {incr i} {
        if {$i > 0 && $i % 10 == 0} {puts $f ""}
        if {$check($i) >= 32 && $check($i) < 128} {
            puts -nonewline $f [format " '%c', " $check($i)]
        } else {
            puts -nonewline $f [format "%4d, " $check($i)]
        }
    }
    puts $f "\n};"    
    close $f
}

# GENERATE INTERPRETER

proc copy_some {f} {
    global skelf

    while {[gets $skelf line] >= 0} {
        if {[regexp {^\$\$} $line]} break
        puts $f $line
    }
}            
            
proc make_body {key action argv} {
    global err_op

    set body $action

    for {set i 0} {$i < [llength $argv]} {incr i} {
        set formal [string index "abcd" $i]
        regsub -all "\\\$$formal" $body [lindex $argv $i] body
    }

    regsub -all {\$s} $body "sp" body
    regexp {\.(.)} $key _ suffix

    switch -glob -- $key {
        B.d {
            # Double from two doubles
            regsub -all {\$1\.d} $body {getdbl(\&sp[0])} body
            regsub -all {\$2\.d} $body {getdbl(\&sp[-2])} body
            return "sp += 2; putdbl(&sp\[0\], $body);"
        }
        B.?dd {
            # Value from two doubles
            regsub -all {\$1\.d} $body {getdbl(\&sp[-1])} body
            regsub -all {\$2\.d} $body {getdbl(\&sp[-3])} body
            return "sp += 3; sp\[0\].$suffix = $body;"
        }           
        B.d?? {
            # Double from two values
            regsub -all {\$1} $body {sp[1]} body
            regsub -all {\$2} $body {sp[0]} body
            return "putdbl(&sp\[0\], $body);"
        }
        B.q {
            # Long from two longs
            regsub -all {\$1\.q} $body {getlong(\&sp[0])} body
            regsub -all {\$2\.q} $body {getlong(\&sp[-2])} body
            return "sp += 2; putlong(&sp\[0\], $body);"
        }
        B.?qq {
            # Value from two longs
            regsub -all {\$1\.q} $body {getlong(\&sp[-1])} body
            regsub -all {\$2\.q} $body {getlong(\&sp[-3])} body
            return "sp += 3; sp\[0\].$suffix = $body;"
        }           
        B.q?? {
            # Long from two values
            regsub -all {\$1} $body {sp[1]} body
            regsub -all {\$2} $body {sp[0]} body
            return "putlong(&sp\[0\], $body);"
        }
        B.x {
            regsub -all {\$1} $body {sp[0]} body
            regsub -all {\$2} $body {sp[-1]} body
            return "sp++; sp\[0\].a = address($body);"
        }
        B.? {
            regsub -all {\$1} $body {sp[0]} body
            regsub -all {\$2} $body {sp[-1]} body
            return "sp++; sp\[0\].$suffix = $body;"
        }
        M.dq {
            regsub -all {\$1\.q} $body {getlong(\&sp[0])} body
            return "putdbl(&sp\[0\], $body);"
        }
        M.qd {
            regsub -all {\$1\.d} $body {getdbl(\&sp[0])} body
            return "putlong(&sp\[0\], $body);"
        }
        M.d {
            regsub -all {\$1\.d} $body {getdbl(\&sp[0])} body
            return "putdbl(&sp\[0\], $body);"
        }
        M.d? {
            # Double from value
            regsub -all {\$1} $body {sp[1]} body
            return "sp--; putdbl(&sp\[0\], $body);"
        }
        M.?d {
            # Value from double
            regsub -all {\$1\.d} $body {getdbl(\&sp[-1])} body
            return "sp++; sp\[0\].$suffix = $body;"
        }           
        M.q {
            regsub -all {\$1\.q} $body {getlong(\&sp[0])} body
            return "putlong(&sp\[0\], $body);"
        }
        M.q? {
            # Long from value
            regsub -all {\$1} $body {sp[1]} body
            return "sp--; putlong(&sp\[0\], $body);"
        }
        M.?q {
            # Value from long
            regsub -all {\$1\.q} $body {getlong(\&sp[-1])} body
            return "sp++; sp\[0\].$suffix = $body;"
        }           
        M.x {
            regsub -all {\$1} $body {sp[0]} body
            return "sp\[0\].a = address($body);"
        }            
        M.? {
            regsub -all {\$1} $body {sp[0]} body
            return "sp\[0\].$suffix = $body;"
        }
        V.d {
            return "sp -= 2; putdbl(&sp\[0\], $body);"
        }
        V.q {
            return "sp -= 2; putlong(&sp\[0\], $body);"
        }
        V.x {
            return "sp--; sp\[0\].a = address($body);"
        }
        V.? {
            return "sp--; sp\[0\].$suffix = $body;"
        }           
        S0 {
            return "{ $body }"
        }
        S[123] {
            regexp {S(.)} $key _ x
            for {set i 1} {$i < $x} {incr i} {
                regsub -all "\\\$$i" $body "sp\[-$i\]" body
            }
            regsub -all "\\\$$x" $body "sp\[-$x\]" body
            return "sp += $x; { $body }"
        }
        S1d {
            regsub -all {\$1\.d} $body {getdbl(\&sp[-2])} body
            return "sp += 2; { $body }"
        }
        S2d? {
            regsub -all {\$1\.d} $body {getdbl(\&sp[-2])} body
            regsub -all {\$2} $body {sp[-3]} body
            return "sp += 3; { $body }"
        }
        S3d?? {
            regsub -all {\$1\.d} $body {getdbl(\&sp[-2])} body
            regsub -all {\$2} $body {sp[-3]} body
            regsub -all {\$3} $body {sp[-4]} body
            return "sp += 4; { $body }"
        }
        S1q {
            regsub -all {\$1\.q} $body {getlong(\&sp[-2])} body
            return "sp += 2; { $body }"
        }
        S2q? {
            regsub -all {\$1\.q} $body {getlong(\&sp[-2])} body
            regsub -all {\$2} $body {sp[-3]} body
            return "sp += 3; { $body }"
        }
        S3q?? {
            regsub -all {\$1\.q} $body {getlong(\&sp[-2])} body
            regsub -all {\$2} $body {sp[-3]} body
            regsub -all {\$3} $body {sp[-4]} body
            return "sp += 4; { $body }"
        }
        T2 {
            regsub -all {\$1} $body {sp[0]} body
            regsub -all {\$2} $body {sp[-1]} body
            return "sp++; { $body }"
        }
        default {
            error "Bad key $key for $err_op"
        }
    }
}

proc gen_interp {name sname} {
    global skelf ncodes opcode defs copy ops action input err_op
    
    set f [open $name "w"]
    set skelf [open $sname "r"]
    
    puts $f "/* Instruction interpreter -- generated by iset.tcl */"
    puts $f ""
                
    copy_some $f
                
    # macros used in action code
    puts $f $defs

    copy_some $f
    
    # jtable array
    for {set i 0} {$i < 256} {incr i} {
        if {$i < $ncodes} {
            with $opcode($i) {op inst patt arg len} {
                puts $f "          &&lbl_$op,"
            }
        } else {
            puts $f "          &&lbl_ILLEGAL,"
        }
    }
    
    copy_some $f
    
    # action code
    foreach op $ops {
        set err_op $op
        with $action($op) {base count length inst key act argv} {
            set act [make_body $key $act $argv]
            puts $f "          ACTION($op)"
            for {set j 1} {$j < $count} {incr j} {
                puts $f "          ALSO($op+$j)"
            }
            puts $f "               pc = pc0 + $length;"
            puts $f "               $act"
            puts $f "               NEXT;"
            puts $f ""
        }
    }
    
    copy_some $f

    close $skelf
    close $f
}


# MAIN PROGRAM

readfile $infile

if {$status != 0} {exit $status}

gen_template $tfile
gen_interp $ifile $srcdir/iskel.c
gen_header $hfile

# Print statistics
puts "Instr     Count  Opcodes"
set fmt "%-10s %3d    %3d"
set count(0) 0;
set count(1) 1; # Allow for ILLEGAL
set count(2) 0
foreach inst $instrs {
    if {$opcount($inst) <= 2} {
        incr count($opcount($inst))
    } else {
        puts [format $fmt $inst 1 $opcount($inst)]
    }
}
puts [format $fmt "singles" $count(1) $count(1)]
puts [format $fmt "doubles" $count(2) [expr {2 * $count(2)}]]
puts [format $fmt "Total" $ninstr $ncodes]

if {$ncodes > 256} {set status 1}

exit $status