annotate keiko/iparse.tcl @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
rev   line source
mike@0 1 #
mike@0 2 # iparse.tcl
mike@0 3 #
mike@0 4 # This file is part of the Oxford Oberon-2 compiler
mike@0 5 # Copyright (c) 2006--2016 J. M. Spivey
mike@0 6 # All rights reserved
mike@0 7 #
mike@0 8 # Redistribution and use in source and binary forms, with or without
mike@0 9 # modification, are permitted provided that the following conditions are met:
mike@0 10 #
mike@0 11 # 1. Redistributions of source code must retain the above copyright notice,
mike@0 12 # this list of conditions and the following disclaimer.
mike@0 13 # 2. Redistributions in binary form must reproduce the above copyright notice,
mike@0 14 # this list of conditions and the following disclaimer in the documentation
mike@0 15 # and/or other materials provided with the distribution.
mike@0 16 # 3. The name of the author may not be used to endorse or promote products
mike@0 17 # derived from this software without specific prior written permission.
mike@0 18 #
mike@0 19 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
mike@0 20 # IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
mike@0 21 # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
mike@0 22 # IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
mike@0 23 # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
mike@0 24 # PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
mike@0 25 # OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
mike@0 26 # WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
mike@0 27 # OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
mike@0 28 # ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
mike@0 29 #
mike@0 30
mike@0 31 # PARSER FOR INSTRUCTION SET DEFINITIONS
mike@0 32
mike@0 33 # The input is a sequence of calls to TCL routines that are
mike@0 34 # defined here. Instructions for the abstract machine are created by
mike@0 35 # calling the routine 'inst' or one of its variants. Each rule has:
mike@0 36 #
mike@0 37 # * A mnemonic, used in the assembly code output by the compiler.
mike@0 38 # * One or more patterns that match arguments of the instruction.
mike@0 39 # * A key that specifies the number and types is the operands and
mike@0 40 # the result of the instruction.
mike@0 41 # * An action, written as a fragment of C code.
mike@0 42 #
mike@0 43 # Patterns:
mike@0 44 # 1/2 Integer (1/2 bytes)
mike@0 45 # [lo,hi,step] Integer encoded in opcode
mike@0 46 # R/S Branch displacement (1/2 bytes)
mike@0 47 #
mike@0 48 # A rule may contain a list of patterns, and produces one template for
mike@0 49 # each pattern. A template corresponds to one opcode or (with the
mike@0 50 # form [lo,hi,step]) several opcodes. It's allowed to have more than
mike@0 51 # one rule for the same instruction, with disjoint patterns.
mike@0 52 #
mike@0 53 # A pattern can describe multiple arguments (so the pattern "1R"
mike@0 54 # describes two operands, a 1-byte integer and a 1-byte displacement),
mike@0 55 # but this may not be combined with range patterns [lo,hi,step], which
mike@0 56 # must always appear alone.
mike@0 57
mike@0 58 # INPUT PROCESSING
mike@0 59
mike@0 60 # syntax -- syntax error message
mike@0 61 proc syntax {msg {n -1}} {
mike@0 62 error $msg
mike@0 63
mike@0 64 global input lcount status
mike@0 65 if {$n < 0} {set n $lcount}
mike@0 66 puts stderr "$input:$n: $msg"
mike@0 67 set status 1
mike@0 68 }
mike@0 69
mike@0 70 set ncodes 0; # No. of opcodes used
mike@0 71 set ntempl 0; # No. of templates
mike@0 72 set ndir 0; # No. of directives
mike@0 73 set ninstr 0; # No. of instructions
mike@0 74 set maxargs 0; # Max args of any template
mike@0 75 set status 0; # Exit status
mike@0 76 set instrs {}; set dirs {}; set ops {}
mike@0 77 set defs {}
mike@0 78
mike@0 79 proc make_inst {inst} {
mike@0 80 global ninstr instrs instrno templates opcount
mike@0 81
mike@0 82 if {[info exists instrno($inst)]} return
mike@0 83 set n [incr ninstr]
mike@0 84 lappend instrs $inst
mike@0 85 set instrno($inst) $n
mike@0 86 set templates($inst) {}
mike@0 87 set opcount($inst) 0
mike@0 88 }
mike@0 89
mike@0 90 proc make_dir {dir} {
mike@0 91 global dirs dirno ndir
mike@0 92 set n [incr ndir]
mike@0 93 lappend dirs $dir
mike@0 94 set dirno($dir) $n
mike@0 95 set templates($dir) {}
mike@0 96 }
mike@0 97
mike@0 98 proc make_template {inst patt bounds op argbytes} {
mike@0 99 global templates ntempl maxargs
mike@0 100 if {$argbytes > 0} {set maxargs [max $maxargs [string length $patt]]}
mike@0 101 lappend templates($inst) [list $patt $bounds $op $argbytes]
mike@0 102 incr ntempl
mike@0 103 }
mike@0 104
mike@0 105 proc make_macro {op codes} {
mike@0 106 global macro
mike@0 107 set macro($op) $codes
mike@0 108 }
mike@0 109
mike@0 110 proc make_action {op base count inst key act argv length} {
mike@0 111 global ops action
mike@0 112
mike@0 113 lappend ops $op
mike@0 114 set action($op) [list $base $count $length $inst $key $act $argv]
mike@0 115 }
mike@0 116
mike@0 117 proc make_opcode {op inst patt arg len} {
mike@0 118 global ncodes
mike@0 119 global opcode
mike@0 120 global opcount
mike@0 121
mike@0 122 incr opcount($inst)
mike@0 123 set opcode($ncodes) [list $op $inst $patt $arg $len]
mike@0 124 incr ncodes
mike@0 125 }
mike@0 126
mike@0 127 # range_arg -- form expression for argument of action code
mike@0 128 proc range_arg {bounds base} {
mike@0 129 # The expression is "ir * step + off", where lo = base * step + off.
mike@0 130 with $bounds {lo hi step} {
mike@0 131 set off [expr {$lo - $base * $step}]
mike@0 132 set exp "ir"
mike@0 133 if {$step != 1} {set exp "$exp*$step"}
mike@0 134 if {$off > 0} {
mike@0 135 set exp "$exp+$off"
mike@0 136 } elseif {$off < 0} {
mike@0 137 set exp "$exp-[expr {-$off}]"
mike@0 138 }
mike@0 139 }
mike@0 140 return $exp
mike@0 141 }
mike@0 142
mike@0 143 proc map_args {patt bounds base vargs} {
mike@0 144 upvar $vargs args
mike@0 145
mike@0 146 set off 1; set args {}
mike@0 147 foreach p [split $patt {}] {
mike@0 148 switch -glob $p {
mike@0 149 N {lappend args [range_arg $bounds $base]}
mike@0 150 [1SK] {lappend args "get1(pc0+$off)"; incr off 1}
mike@0 151 [2RTL] {lappend args "get2(pc0+$off)"; incr off 2}
mike@0 152 default {syntax "Bad pattern code $p"}
mike@0 153 }
mike@0 154 }
mike@0 155 return [expr {$off - 1}]
mike@0 156 }
mike@0 157
mike@0 158 # process -- process an instruction definition
mike@0 159 proc process {inst patts key action} {
mike@0 160 global ncodes status
mike@0 161
mike@0 162 if {$patts == "0"} {set patts [list ""]}
mike@0 163 make_inst $inst
mike@0 164
mike@0 165 set j 0
mike@0 166 foreach patt $patts {
mike@0 167 if {[regexp {^\[(.*),(.*),(.*)\]} $patt _ lo hi step]} {
mike@0 168 regsub {^\[.*\]} $patt "N" patt
mike@0 169 if {[llength $patts] == 1} {
mike@0 170 set op $inst
mike@0 171 } else {
mike@0 172 set op "${inst}_x[incr j]"
mike@0 173 }
mike@0 174 } else {
mike@0 175 set lo 0; set hi 0; set step 0
mike@0 176 if {$patt == ""} {
mike@0 177 set op $inst
mike@0 178 } else {
mike@0 179 set op "${inst}_$patt"
mike@0 180 }
mike@0 181 }
mike@0 182
mike@0 183 if {![regexp {^[12RSTNKL]*$} $patt]} {
mike@0 184 syntax "Bad pattern $patt"
mike@0 185 }
mike@0 186
mike@0 187 # Compute offsets for the arguments
mike@0 188 set base $ncodes; set n 0
mike@0 189 set bounds [list $lo $hi $step]
mike@0 190 set arglen [map_args $patt $bounds $base args]
mike@0 191 set totlen [expr {$arglen+1}]
mike@0 192
mike@0 193 for {set arg $lo} {$arg <= $hi} {incr arg [expr {$step>0?$step:1}]} {
mike@0 194 make_opcode $op $inst $patt $arg $totlen
mike@0 195 incr n
mike@0 196 }
mike@0 197
mike@0 198 make_template $inst $patt $bounds $op $arglen
mike@0 199 make_action $op $base $n $inst $key $action $args $totlen
mike@0 200 }
mike@0 201 }
mike@0 202
mike@0 203 proc defs {text} {
mike@0 204 global defs
mike@0 205 append defs "$text\n"
mike@0 206 }
mike@0 207
mike@0 208 # Create an instruction
mike@0 209 proc inst {inst patts key act} {
mike@0 210 process $inst $patts $key $act
mike@0 211 }
mike@0 212
mike@0 213 # Create a dummy instruction (used for CASE labels)
mike@0 214 proc zinst {inst template} {
mike@0 215 make_inst $inst
mike@0 216 if {$template != "0"} {
mike@0 217 set arglen [map_args $template none 0 args]
mike@0 218 make_template $inst $template {0 0 0} NOP $arglen
mike@0 219 }
mike@0 220 }
mike@0 221
mike@0 222 # Create an assembler directive
mike@0 223 proc dir {inst patt} {
mike@0 224 # A directive
mike@0 225 if {$patt == "0"} {set patt ""}
mike@0 226 make_dir $inst
mike@0 227 make_template $inst $patt {0 0 0} $inst -1
mike@0 228 }
mike@0 229
mike@0 230 # Make an instruction equivalent to a sequence of others
mike@0 231 proc equiv {inst patt equiv} {
mike@0 232 global ncodes status
mike@0 233
mike@0 234 if {$patt == "0"} {
mike@0 235 set patt ""; set op $inst
mike@0 236 } else {
mike@0 237 set op "${inst}_$patt"
mike@0 238 }
mike@0 239
mike@0 240 set arglen [map_args $patt none 0 args]
mike@0 241 set codes [map trim [split $equiv ","]]
mike@0 242
mike@0 243 make_inst $inst
mike@0 244 make_template $inst $patt {0 0 0} $op $arglen
mike@0 245 make_macro $op $codes
mike@0 246 }
mike@0 247
mike@0 248 # Provide expansion for use by JIT translator
mike@0 249 proc expand {inst patt equiv} {
mike@0 250 global expand
mike@0 251 set expand($inst) [map trim [split $equiv ","]]
mike@0 252 }
mike@0 253
mike@0 254 proc readfile {name} {
mike@0 255 global input opcount
mike@0 256
mike@0 257 set input $name
mike@0 258
mike@0 259 set opcount(ILLEGAL) 0
mike@0 260 make_opcode ILLEGAL ILLEGAL "" 0 1
mike@0 261
mike@0 262 uplevel #0 source $name
mike@0 263 }
mike@0 264