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