comparison 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
comparison
equal deleted inserted replaced
-1:000000000000 0:bfdcc3820b32
1 #
2 # iset.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 # This workaround is needed with TCL 8.4.2 if output goes to an emacs
32 # compilation buffer.
33 fconfigure stdout -translation lf
34 fconfigure stderr -translation lf
35
36 if {[llength $argv] != 4} {
37 puts stderr "usage: iset input.iset header template interp"
38 exit 1
39 }
40
41 set srcdir [file dirname $argv0]
42 source "$srcdir/util.tcl"
43 source "$srcdir/iparse.tcl"
44
45 if {[file exists "config.tcl"]} {source "config.tcl"}
46
47 lsplit $argv infile hfile tfile ifile
48
49 # BUILD THE TRIE
50
51 # make_trie -- recursively build a trie for a set of strings
52 proc make_trie {n strings} {
53 global charcode first trie taken check ntrie
54
55 # Assume the strings agree on the first n characters
56
57 if {[llength $strings] == 0} {
58 puts stderr "Empty trie!!!"
59 return -9999
60 }
61
62 # Set chars to the set of n'th characters of the strings
63 set chars [remdups [lsort [map {nth_char $n} $strings]]]
64 set c1 $charcode([lindex $chars 0])
65
66 # Find a place where a node for $chars will fit -- 0 for the root
67 for {set q 0} {1} {incr q} {
68 if {[info exists taken($q)]} continue
69
70 while {$ntrie <= $q+128} {
71 set trie($ntrie) 0
72 set check($ntrie) 128
73 incr ntrie
74 }
75
76 set ok 1
77 foreach c $chars {
78 set ix [expr {$q+$charcode($c)}]
79 if {$check($ix) != 128} {
80 set ok 0; break
81 }
82 }
83
84 if {$ok} break
85 }
86
87 # Reserve the locations we will use by filling in check
88 # (actual values in trie get filled in later)
89 set taken($q) 1
90
91 foreach c $chars {
92 set ix [expr {$q+$charcode($c)}]
93 set check($ix) $charcode($c)
94 }
95
96 # Recursively build sub-tries
97 foreach c $chars {
98 if {$c == ""} {
99 set t [string range [lindex $strings 0] 0 [expr {$n-1}]]
100 set trie($q) $first($t)
101 set check($q) 0
102 } else {
103 set ix [expr {$q+$charcode($c)}]
104 set subset [filter {nth_char_is $n $c} $strings]
105 set trie($ix) [make_trie [expr {$n+1}] $subset]
106 set check($ix) $charcode($c)
107 }
108 }
109
110 return $q
111 }
112
113 proc has_templates {i} {
114 global templates
115 return [expr {[llength $templates($i)] > 0}]
116 }
117
118 # Build a packed trie for the instructions
119 proc build_trie {} {
120 global ntrie instrs dirs
121 set ntrie 0
122 make_trie 0 [filter has_templates [concat $instrs $dirs]]
123 }
124
125 proc dmp_trie {f q pfx} {
126 global trie check ntrie
127
128 set sep ""
129 if {$check($q) == 0} {
130 puts $f [format "--> %d" $trie($q)]
131 set sep $pfx
132 }
133 set nchild 0
134 for {set c 1} {$c < 128} {incr c} {
135 set i [expr {$q+$c}]
136 if {$check($i) == $c} {
137 set char($nchild) $c
138 set son($nchild) $trie($i)
139 incr nchild
140 }
141 }
142
143 for {set j 0} {$j < $nchild} {incr j} {
144 puts -nonewline $f [format "%s\[%c\] %3d " $sep $char($j) $son($j)]
145 if {$j+1 < $nchild} {
146 set slug " | "
147 } else {
148 set slug " "
149 }
150 dmp_trie $f $son($j) "$pfx$slug"
151 set sep $pfx
152 }
153 }
154
155
156 # GENERATE HEADER FILE
157
158 proc gen_header {name} {
159 global ntempl maxargs instrs instrno dirs dirno ops action ntrie \
160 expand opcode ncodes
161
162 set f [open $name "w"]
163 puts $f "/* Header file -- generated by iset.tcl */"
164 puts $f ""
165 puts $f "#define NTEMPLATES $ntempl"
166 puts $f "#define NTRIE $ntrie"
167 puts $f "#define MAXARGS $maxargs"
168 puts $f ""
169
170 puts $f "#define __INSTRS__(i) \\"
171 puts -nonewline $f " i(ILLEGAL)"
172 foreach i $instrs {
173 set m [list [csym "" $i]]
174 if {[info exists expand($i)]} {
175 foreach x $expand($i) {
176 if {[regexp {^(.*) \$a$} $x _ y]} {
177 lappend m "[csym I $y]|IARG"
178 } elseif {[regexp {^(.*) (-?[0-9]*)$} $x _ y z]} {
179 lappend m "[csym I $y]|ICON" $z
180 } else {
181 lappend m "[csym I $x]"
182 }
183 }
184 }
185 puts -nonewline $f \
186 " \\\n i([join $m ", "])"
187 }
188 puts $f ""
189 puts $f ""
190 puts $f "#define __i1__(sym, ...) I_##sym,"
191 puts $f "enum { __INSTRS__(__i1__) };"
192 puts $f ""
193
194 puts $f "#define __DIRS__(d) \\"
195 puts -nonewline $f " d(ILLEGAL)"
196 foreach d $dirs {
197 puts -nonewline $f " \\\n d([csym "" $d])"
198 }
199 puts $f ""
200 puts $f ""
201 puts $f "#define __d1__(sym) D_##sym,"
202 puts $f "enum { __DIRS__(__d1__) };"
203 puts $f ""
204
205 # Not an enum, because bases are not contiguous!
206 puts $f "#define K_ILLEGAL 0"
207 foreach op $ops {
208 with $action($op) {base count length inst key act args} {
209 puts $f "#define [csym K $op] $base"
210 }
211 }
212 puts $f ""
213
214 puts -nonewline $f "#define __OPCODES__(o)"
215 for {set i 0} {$i < $ncodes} {incr i} {
216 with $opcode($i) {op inst patt arg len} {
217 puts -nonewline $f \
218 " \\\n o($op, $inst, \"$patt\", $arg, $len)"
219 }
220 }
221 puts $f ""
222
223 close $f
224 }
225
226 # GENERATE TEMPLATE FILE
227
228 # make_code -- assemble equivalent code
229 proc make_code {op} {
230 global ops dirs status
231
232 if {$op == "NOP"} {
233 return {}
234 } elseif {[lmember $op $ops]} {
235 return [csym K $op]
236 } elseif {[lmember $op $dirs]} {
237 return [csym D $op]
238 } else {
239 puts stderr "Code $op does not exist"
240 set status 1
241 }
242 }
243
244 proc quote {s} {return "\"$s\""}
245
246 proc gen_template {name} {
247 global templates instrs dirs first ntrie trie check macro
248
249 set f [open $name "w"]
250 puts $f "/* Template file -- generated by iset.tcl */"
251 puts $f ""
252 puts $f "#include \"oblink.h\""
253 puts $f "#include \"keiko.h\""
254 puts $f ""
255
256 set nt 0
257 set fmt "{%-12s %-7s%3d, %2d, %2d, %2d, %2d, %s, {%s}},"
258 puts $f "struct _template templates\[NTEMPLATES\] = {"
259 foreach inst [concat $instrs $dirs] {
260 set first($inst) $nt
261 foreach templ $templates($inst) {
262 with $templ {patt bounds op argsz} {
263 with $bounds {lo hi step} {
264 if {$nt == $first($inst)} {
265 set icode "\"$inst\""
266 } else {
267 set icode " NULL"
268 }
269 if {[info exists macro($op)]} {
270 set maclines [map quote $macro($op)]
271 puts $f \
272 [format $fmt "$icode," "\"$patt\"," \
273 $lo $hi $step 0 0 0 [join $maclines ", "]]
274 } else {
275 if {$op == "NOP"} {
276 set n 0; set c 0
277 } else {
278 set n 1; set c [make_code $op]
279 }
280 set len [expr {$argsz >= 0 ? $n + $argsz : $argsz}]
281 puts $f \
282 [format $fmt "$icode," "\"$patt\"," \
283 $lo $hi $step $len $n $c ""]
284 }
285 }
286 }
287 incr nt
288 }
289 }
290 puts $f "};";
291 puts $f "";
292
293 build_trie
294
295 puts $f "/*"
296 dmp_trie $f 0 ""
297 puts $f "*/"
298 puts $f ""
299
300 puts $f "short templ_trie\[NTRIE\] = {"
301 for {set i 0} {$i < $ntrie} {incr i} {
302 if {$i > 0 && $i % 10 == 0} {puts $f ""}
303 puts -nonewline $f [format "%4d, " $trie($i)]
304 }
305 puts $f "\n};"
306 puts $f "";
307 puts $f "uchar templ_check\[NTRIE\] = {"
308 for {set i 0} {$i < $ntrie} {incr i} {
309 if {$i > 0 && $i % 10 == 0} {puts $f ""}
310 if {$check($i) >= 32 && $check($i) < 128} {
311 puts -nonewline $f [format " '%c', " $check($i)]
312 } else {
313 puts -nonewline $f [format "%4d, " $check($i)]
314 }
315 }
316 puts $f "\n};"
317 close $f
318 }
319
320 # GENERATE INTERPRETER
321
322 proc copy_some {f} {
323 global skelf
324
325 while {[gets $skelf line] >= 0} {
326 if {[regexp {^\$\$} $line]} break
327 puts $f $line
328 }
329 }
330
331 proc make_body {key action argv} {
332 global err_op
333
334 set body $action
335
336 for {set i 0} {$i < [llength $argv]} {incr i} {
337 set formal [string index "abcd" $i]
338 regsub -all "\\\$$formal" $body [lindex $argv $i] body
339 }
340
341 regsub -all {\$s} $body "sp" body
342 regexp {\.(.)} $key _ suffix
343
344 switch -glob -- $key {
345 B.d {
346 # Double from two doubles
347 regsub -all {\$1\.d} $body {getdbl(\&sp[0])} body
348 regsub -all {\$2\.d} $body {getdbl(\&sp[-2])} body
349 return "sp += 2; putdbl(&sp\[0\], $body);"
350 }
351 B.?dd {
352 # Value from two doubles
353 regsub -all {\$1\.d} $body {getdbl(\&sp[-1])} body
354 regsub -all {\$2\.d} $body {getdbl(\&sp[-3])} body
355 return "sp += 3; sp\[0\].$suffix = $body;"
356 }
357 B.d?? {
358 # Double from two values
359 regsub -all {\$1} $body {sp[1]} body
360 regsub -all {\$2} $body {sp[0]} body
361 return "putdbl(&sp\[0\], $body);"
362 }
363 B.q {
364 # Long from two longs
365 regsub -all {\$1\.q} $body {getlong(\&sp[0])} body
366 regsub -all {\$2\.q} $body {getlong(\&sp[-2])} body
367 return "sp += 2; putlong(&sp\[0\], $body);"
368 }
369 B.?qq {
370 # Value from two longs
371 regsub -all {\$1\.q} $body {getlong(\&sp[-1])} body
372 regsub -all {\$2\.q} $body {getlong(\&sp[-3])} body
373 return "sp += 3; sp\[0\].$suffix = $body;"
374 }
375 B.q?? {
376 # Long from two values
377 regsub -all {\$1} $body {sp[1]} body
378 regsub -all {\$2} $body {sp[0]} body
379 return "putlong(&sp\[0\], $body);"
380 }
381 B.x {
382 regsub -all {\$1} $body {sp[0]} body
383 regsub -all {\$2} $body {sp[-1]} body
384 return "sp++; sp\[0\].a = address($body);"
385 }
386 B.? {
387 regsub -all {\$1} $body {sp[0]} body
388 regsub -all {\$2} $body {sp[-1]} body
389 return "sp++; sp\[0\].$suffix = $body;"
390 }
391 M.dq {
392 regsub -all {\$1\.q} $body {getlong(\&sp[0])} body
393 return "putdbl(&sp\[0\], $body);"
394 }
395 M.qd {
396 regsub -all {\$1\.d} $body {getdbl(\&sp[0])} body
397 return "putlong(&sp\[0\], $body);"
398 }
399 M.d {
400 regsub -all {\$1\.d} $body {getdbl(\&sp[0])} body
401 return "putdbl(&sp\[0\], $body);"
402 }
403 M.d? {
404 # Double from value
405 regsub -all {\$1} $body {sp[1]} body
406 return "sp--; putdbl(&sp\[0\], $body);"
407 }
408 M.?d {
409 # Value from double
410 regsub -all {\$1\.d} $body {getdbl(\&sp[-1])} body
411 return "sp++; sp\[0\].$suffix = $body;"
412 }
413 M.q {
414 regsub -all {\$1\.q} $body {getlong(\&sp[0])} body
415 return "putlong(&sp\[0\], $body);"
416 }
417 M.q? {
418 # Long from value
419 regsub -all {\$1} $body {sp[1]} body
420 return "sp--; putlong(&sp\[0\], $body);"
421 }
422 M.?q {
423 # Value from long
424 regsub -all {\$1\.q} $body {getlong(\&sp[-1])} body
425 return "sp++; sp\[0\].$suffix = $body;"
426 }
427 M.x {
428 regsub -all {\$1} $body {sp[0]} body
429 return "sp\[0\].a = address($body);"
430 }
431 M.? {
432 regsub -all {\$1} $body {sp[0]} body
433 return "sp\[0\].$suffix = $body;"
434 }
435 V.d {
436 return "sp -= 2; putdbl(&sp\[0\], $body);"
437 }
438 V.q {
439 return "sp -= 2; putlong(&sp\[0\], $body);"
440 }
441 V.x {
442 return "sp--; sp\[0\].a = address($body);"
443 }
444 V.? {
445 return "sp--; sp\[0\].$suffix = $body;"
446 }
447 S0 {
448 return "{ $body }"
449 }
450 S[123] {
451 regexp {S(.)} $key _ x
452 for {set i 1} {$i < $x} {incr i} {
453 regsub -all "\\\$$i" $body "sp\[-$i\]" body
454 }
455 regsub -all "\\\$$x" $body "sp\[-$x\]" body
456 return "sp += $x; { $body }"
457 }
458 S1d {
459 regsub -all {\$1\.d} $body {getdbl(\&sp[-2])} body
460 return "sp += 2; { $body }"
461 }
462 S2d? {
463 regsub -all {\$1\.d} $body {getdbl(\&sp[-2])} body
464 regsub -all {\$2} $body {sp[-3]} body
465 return "sp += 3; { $body }"
466 }
467 S3d?? {
468 regsub -all {\$1\.d} $body {getdbl(\&sp[-2])} body
469 regsub -all {\$2} $body {sp[-3]} body
470 regsub -all {\$3} $body {sp[-4]} body
471 return "sp += 4; { $body }"
472 }
473 S1q {
474 regsub -all {\$1\.q} $body {getlong(\&sp[-2])} body
475 return "sp += 2; { $body }"
476 }
477 S2q? {
478 regsub -all {\$1\.q} $body {getlong(\&sp[-2])} body
479 regsub -all {\$2} $body {sp[-3]} body
480 return "sp += 3; { $body }"
481 }
482 S3q?? {
483 regsub -all {\$1\.q} $body {getlong(\&sp[-2])} body
484 regsub -all {\$2} $body {sp[-3]} body
485 regsub -all {\$3} $body {sp[-4]} body
486 return "sp += 4; { $body }"
487 }
488 T2 {
489 regsub -all {\$1} $body {sp[0]} body
490 regsub -all {\$2} $body {sp[-1]} body
491 return "sp++; { $body }"
492 }
493 default {
494 error "Bad key $key for $err_op"
495 }
496 }
497 }
498
499 proc gen_interp {name sname} {
500 global skelf ncodes opcode defs copy ops action input err_op
501
502 set f [open $name "w"]
503 set skelf [open $sname "r"]
504
505 puts $f "/* Instruction interpreter -- generated by iset.tcl */"
506 puts $f ""
507
508 copy_some $f
509
510 # macros used in action code
511 puts $f $defs
512
513 copy_some $f
514
515 # jtable array
516 for {set i 0} {$i < 256} {incr i} {
517 if {$i < $ncodes} {
518 with $opcode($i) {op inst patt arg len} {
519 puts $f " &&lbl_$op,"
520 }
521 } else {
522 puts $f " &&lbl_ILLEGAL,"
523 }
524 }
525
526 copy_some $f
527
528 # action code
529 foreach op $ops {
530 set err_op $op
531 with $action($op) {base count length inst key act argv} {
532 set act [make_body $key $act $argv]
533 puts $f " ACTION($op)"
534 for {set j 1} {$j < $count} {incr j} {
535 puts $f " ALSO($op+$j)"
536 }
537 puts $f " pc = pc0 + $length;"
538 puts $f " $act"
539 puts $f " NEXT;"
540 puts $f ""
541 }
542 }
543
544 copy_some $f
545
546 close $skelf
547 close $f
548 }
549
550
551 # MAIN PROGRAM
552
553 readfile $infile
554
555 if {$status != 0} {exit $status}
556
557 gen_template $tfile
558 gen_interp $ifile $srcdir/iskel.c
559 gen_header $hfile
560
561 # Print statistics
562 puts "Instr Count Opcodes"
563 set fmt "%-10s %3d %3d"
564 set count(0) 0;
565 set count(1) 1; # Allow for ILLEGAL
566 set count(2) 0
567 foreach inst $instrs {
568 if {$opcount($inst) <= 2} {
569 incr count($opcount($inst))
570 } else {
571 puts [format $fmt $inst 1 $opcount($inst)]
572 }
573 }
574 puts [format $fmt "singles" $count(1) $count(1)]
575 puts [format $fmt "doubles" $count(2) [expr {2 * $count(2)}]]
576 puts [format $fmt "Total" $ninstr $ncodes]
577
578 if {$ncodes > 256} {set status 1}
579
580 exit $status