layout/data2safety

   1 #!/usr/bin/perl -w
   2
   3 use strict qw(vars);
   4
   5 our ($basename);
   6 $basename= @ARGV ? $ARGV[0] : 'safety';
   7 die if $basename =~ m/^\-/;
   8 $basename =~ s/\.wiring$//;
   9
  10 our ($mistakes, $currentline);
  11
  12 our (%segs);
  13 # $segs{$seg}{Inv}
  14 # $segs{$seg}{BoOb}
  15 # $segs{$seg}{Posns}
  16 # $segs{$seg}{FeatCount}              does not include Fixed
  17 # $segs{$seg}{Feats}{$pt}{Kind}       Point or Fixed
  18 # $segs{$seg}{Feats}{$pt}{Weight}     ) for Point only
  19 # $segs{$seg}{Feats}{$pt}{Posns}      ) for Point only
  20 # $segs{$seg}{Feats}{$pt}{BoOb}[]     ) for Point only
  21 # $segs{$seg}{Feats}{$pt}{Fixed}      position, for Fixed only
  22
  23 # $segs{$seg}{Num}
  24 # $segs{$seg}{Ends}[$combpos][$end] = [ $node,$side ]
  25 # $segs{$seg}{Dist}[$combpos]
  26
  27 our (%nodes);
  28 # $nodes{$node}[$side]{Seg}
  29 # $nodes{$node}[$side]{End}
  30
  31 our ($nextboardnum,@boardtype,%numboards,$nreverses,@sensesin,@sensesbase);
  32 # @boardtype[$boardnum]
  33 # $numboards{$type}
  34 # $nreverses
  35 # $sensesin[$page]
  36 # $sensesbase[$boardnum]= ($page << 7) | $baselsbyte
  37 $nextboardnum= 0;
  38 $nreverses= 0;
  39 $sensesin[0]= 0;
  40 @objkinds= qw(pt sense reverse);
  41
  42 our (%kind_count,%pin_info); # from BOARD.pin-info
  43
  44 our ($mode,$invertible);
  45 $mode= 'barf';
  46
  47 sub line_barf () {
  48     return if $mistakes;
  49     mistake("first input line does not determine phase");
  50 }
  51
  52 sub syntaxerror () {
  53     our (%syntaxerror_once);
  54     return if exists $syntaxerror_once{$mode};
  55     $syntaxerror_once{$mode}= 1;
  56     mistake("syntax error");
  57     return undef;
  58 }
  59
  60 sub ditch ($) {
  61     my ($m) = @_;
  62     print STDERR "ditching $m\n";
  63 }
  64
  65 sub begin_points () { }
  66 sub line_points () {
  67     my ($seg,$pt,@boob,$bodef);
  68     m,^\s+(\w+)/([A-Za-z]+)\s+((\d+)\.\d+)\s+(\d*\.\d+)$, or
  69         return syntaxerror();
  70     ($seg,$pt,$boob[0],$bodef,$boob[1])=($1,$2,$3,$4,$5);
  71     $boob[1] =~ s/^\./$bodef./;
  72     mistake("unknown wiring for $seg in $seg/$pt") unless exists $segs{$seg};
  73     mistake("duplicate wiring for $seg/$pt") if exists $segs{$seg}{Feats}{$pt};
  74     $segs{$seg}{Feats}{$pt}= {
  75         Kind => Point,
  76         Weight => $segs{$seg}{Posns},
  77         Posns => 2,
  78         BoOb => [ map { pa_boob($_) } @boob ]
  79         };
  80     $segs{$seg}{Posns} *= 2;
  81     $segs{$seg}{FeatCount}++;
  82 }
  83
  84 sub begin_fixed () { }
  85 sub line_fixed () {
  86     my ($seg,$pt,$pos);
  87     m,^\s+(\w+)/([A-Za-z]+)(\d+)$, or return syntaxerror();
  88     ($seg,$pt,$pos)=($1,$2,$3);
  89     mistake("unknown wiring for $seg in $seg/$pt") unless exists $segs{$seg};
  90     mistake("duplicate fixed $seg/$pt") if exists $segs{$seg}{Feats}{$pt};
  91     $segs{$seg}{Feats}{$pt}= {
  92         Kind => Fixed,
  93         Fixed => $pos
  94         };
  95 }
  96
  97 sub begin_segment () { }
  98 sub line_segment () {
  99     my ($seg,$boob);
 100     m/^\s+(\w+)\s+(\d+\.\d+)$/ or return syntaxerror();
 101     ($seg,$boob)=($1,$2);
 102     mistake("duplicate topology for $seg") if exists $segs{$seg};
 103     $segs{$seg}= {
 104         BoOb => pa_boob($boob),
 105         Inv => $invertible,
 106         Posns => 1,
 107         Feats => { },
 108         FeatCount => 0
 109     };
 110 }
 111
 112 sub begin_endwiring () {
 113 }
 114
 115 sub begin_boards () {
 116 }
 117 sub line_boards () {
 118     my ($num,$type,$k);
 119     m/^\s+(\d+)\s+(\w+)$/ or return syntaxerror();
 120     ($num,$type)=($1,$2);
 121     mistake("board $num when expected $nextboardnum")
 122         if $num != $nextboardnum;
 123
 124     $nextboardnum++;
 125     $boardtype[$num]= $type;
 126     $numboards{$type}++;
 127     require "./$type.pin-info";
 128
 129     my ($sense_count, $page);
 130     $sense_count= $kind_count{$type}{'sense'};
 131     for ($page=0;
 132          $sensesin[$page] + $sense_count > 128;
 133          $page++) {
 134         mistake("too many senses for encoding scheme")
 135             if $page > 7;
 136         push @sensesin, 0
 137             if $page > $#sensesin;
 138     }
 139     $sensesbase[$num]= ($page << 7) | $sensesin[$page];
 140     $sensesin[$page] += $sense_count;
 141
 142     &{"line_board_$type"}($num);
 143 }
 144
 145 sub line_board_reversers ($) {
 146     my ($num) = @_;
 147     my ($i,$objnum);
 148     for ($i=0; $i<5; $i++) {
 149         $objnum= so_boob('reverse', [ $num,$i ]);
 150         $nreverses= $objnum+1 if $objnum >= $nreverses;
 151     }
 152 }
 153
 154 sub mistake ($) {
 155     my ($m) = @_;
 156     print STDERR "mistake: $m\n in $mode, \`$currentline'\n";
 157     $mistakes++;
 158 }
 159
 160 sub line_endwiring () {
 161     my (@ns,$seg,$subspec,$dist);
 162     my ($segr,@subsegil,$feat,$pos,$featr,$combpos,%featposwant);
 163     my ($end,$node,$side,$nsr,$endposr);
 164     m,^\s*segment\s+(\w+\.\d+)\s+(\w+\.\d+)\s+(\w+)(?:/((?:[A-Za-z]+\d+)+)\*\d+)?\s+([0-9.]+)$, or return syntaxerror();
 165     ($ns[0],$ns[1],$seg,$subspec,$dist)=($1,$2,$3,$4,$5);
 166     if (!exists $segs{$seg}) {
 167         ditch("unwired $seg$subspec");
 168         return;
 169     }
 170     $segr= $segs{$seg};
 171     @subsegil= defined $subspec ? $subspec =~ m/([A-Za-z]+)(\d+)/g : ();
 172     while (@subsegil) {
 173         ($feat,$pos,@subsegil) = @subsegil;
 174         if (!exists $segr->{Feats}{$feat}) {
 175             mistake("no wiring for $seg/$feat");
 176             next;
 177         }
 178         $featr= $segr->{Feats}{$feat};
 179         if (exists $featr->{Fixed}) {
 180             if ($pos != $featr->{Fixed}) {
 181                 ditch("fixed-elsewise $seg$subspec");
 182                 return;
 183             }
 184         } else {
 185             mistake("position $seg/$feat$pos exceeds wiring")
 186                 unless $pos < $featr->{Posns};
 187             $featposwant{$feat}= $pos;
 188         }
 189     }
 190     $combpos= 0;
 191     for $feat (keys %{ $segr->{Feats} }) {
 192         $featr= $segr->{Feats}{$feat};
 193         next if exists $featr->{Fixed};
 194         mistake("wiring $seg/$feat not covered by $seg/$subspec")
 195             if !exists $featposwant{$feat};
 196         $combpos += $featposwant{$feat} * $featr->{Weight};
 197     }
 198     mistake("duplicate topology for $seg/$subspec")
 199         if defined $segs{$seg}{Dist}[$combpos];
 200     $segs{$seg}{Dist}[$combpos]= $dist;
 201     $endposr= $segr->{Ends}[$combpos];
 202     die "$seg $combpos @$endposr ?" if defined $endposr && @$endposr;
 203     for ($end=0; $end<2; $end++) {
 204         $ns[$end] =~ m/^([a-z]\w+)\.([01])$/;
 205         ($node,$side)=($1,$2);
 206         $nsr= $nodes{$node}[$side];
 207         if (!exists $nsr->{Seg}) {
 208             $nodes{$node}[$side]= { Seg => $seg, End => $end };
 209         } else {
 210             $seg eq $nsr->{Seg} or
 211                 mistake("topology for $node.$side both $seg and $nsr->{Seg}");
 212             $end == $nsr->{End} or
 213                 mistake("topology for $node.$side $seg both ends ($end".
 214                         " and also $nsr->{End})");
 215         }
 216         $segr->{Ends}[$combpos][$end]= [ $node, $side ];
 217     }
 218 }
 219
 220 sub o ($) {
 221     print STDOUT $_[0] or die $!;
 222 }
 223
 224 sub pa_boob ($) {
 225     my ($boob) = @_;
 226     if ($boob !~ m/^([1-9]\d*|0)\.([1-9]\d*|0)$/) {
 227         mistake("invalid board object $boob");
 228         return [ 0,0 ];
 229     }
 230     return [ $1,$2 ];
 231 }
 232
 233 # so_boob_KIND($boardnum,$objnum,$boardtype,$pininfo) -> global object number
 234
 235 sub so_boob_pt {
 236     my ($boardnum,$obj)=@_;
 237     mistake("point encoding out of range") if $boardnum>31;
 238     die if $obj > 31;
 239     return ($boardnum << 5) | $obj;
 240 }
 241
 242 sub so_boob_reverse {
 243     my ($boardnum,$obj,$boardtype)=@_;
 244
 245     # Converts board and object number (in canonical pic number plus
 246     # and reverse0...reverse5 as seen on pinout diagrams), to
 247     # object number for POLARITY command numbered as shown in
 248     # README.protocol.
 249     #
 250     # There are three basic stages:
 251     #
 252     #  * We invert the on-board mapping; ie, we untangle the
 253     #    tangling between the message from master to slave pic
 254     #    and the actual pins (see reverse.asm, polarity_do_here)
 255     #
 256     #  * We figure out which bit of which message byte the
 257     #    object corresponds to.  (see reverse.asm, polarity_decode_message)
 258     #
 259     #  * We compute the README.protocol bit and byte number.
 260
 261     my ($cycle,$boardincycle,$cyclebasebyte,$byte,$bit);
 262     die unless $boardtype eq 'reversers';
 263     die if $obj > 5;
 264     $obj = sprintf '%d', $obj;
 265     $obj =~ y/302154/543210/; # mapping due to polarity_do_here
 266     $cycle= int(($boardnum+3) / 7);
 267     $boardincycle= ($boardnum+3) - $cycle*7;
 268     $cyclebasebyte= $cycle*6 - 2;
 269     if ($boardnum==2 && $obj > 2) {
 270         $byte= 0; $bit= $obj-3;
 271         return 3 - $bit; # only these three in byte 0, a special case
 272     } elsif ($boardincycle<5) {
 273         $byte= $cyclebasebyte + $boardincycle; $bit= $obj;
 274     } elsif ($boardincycle==6) {
 275         $byte= $cyclebasebyte + 5; $bit= $obj;
 276     } elsif ($boardincycle==5) {
 277         $byte= $cyclebasebyte + 5 - $bit; $bit= 6;
 278     } else {
 279         die;
 280     }
 281     return $byte*7 + 3 - $bit;
 282 }
 283
 284 sub so_boob_sense($$$) {
 285     my ($boardnum,$obj)=@_;
 286     my ($inpage);
 287     $inpage= $obj + $sensesbase[$boardnum];
 288     die if $inpage > 127;
 289     return ($boardnum << 7) | $inpage;
 290 }
 291
 292 sub so_boob ($$) {
 293     my ($kind,$bo) = @_;
 294     if (defined $bo) {
 295         my ($board,$obj)= @$bo;
 296         my ($objnum,$type,$pi);
 297         mistake("unknown board number $board")
 298             unless defined $boardtype[$board];
 299         $type= $boardtype[$board];
 300         $pi= $pin_info{$type}{$kind};
 301         mistake("object reference $kind $board.$obj out of range for".
 302                 " board type $type")
 303             unless defined $pi->[$obj];
 304         $objnum= &{"so_boob_$kind"}($board,$obj,$type,$pi);
 305         $pin_used{$kind}[$objnum]= [ $board, $pi->[$obj], $obj ];
 306         return sprintf("%4d /* %d.%-2d*/", $objnum, $board, $obj);
 307     } else {
 308         return "   0 /*none*/ ";
 309     }
 310 }
 311
 312 sub so_oboob ($$) {
 313     my ($kind,$obj) = @_;
 314     return so_boob($kind, defined $obj ? $obj->{BoOb} : undef);
 315 }
 316
 317 sub mainread () {
 318     $mistakes= 0;
 319     while (<>) {
 320         next if m/^\#/;
 321         chomp;
 322         s/\s+$//;
 323         next unless m/\S/;
 324         last if m/^end$/;
 325         if (m/^(invertible|vanilla|points|fixed|endwiring|boards)$/) {
 326             $mode= $1;
 327             $invertible= ($mode eq 'invertible');
 328             $mode= 'segment' if $mode =~ m/^(?:vanilla|invertible)$/;
 329             &{"begin_$mode"};
 330         } else {
 331             $currentline= $_;
 332             &{"line_$mode"};
 333         }
 334     }
 335 }
 336
 337 sub nummap ($) {
 338     my ($p) = @_;
 339     $p =~ s/\d{1,6}/ sprintf "%06d%d",$&,$& /ge;
 340     return $p;
 341 }
 342
 343 sub writeout () {
 344     my (@segs,$segn,$seg,$segr,$pt,$ptv, $delim);
 345     my ($comb,$pi,$feat,$featr,$end,$boob);
 346     my ($node,$side,$otherend,$nodeotherside,$otherseg,$otherbackrelus);
 347     o("/* autogenerated - do not edit */\n\n");
 348     @segs=();
 349     for $seg (sort { nummap($a) cmp nummap($b) } keys %segs) {
 350         $segs{$seg}{Num}= @segs;
 351         push @segs, $seg;
 352     }
 353     o(sprintf
 354       "#define NUM_TRAINS 1000000\n".
 355       "#define NUM_SEGMENTS %s\n\n".
 356       "#include \"layout-data.h\"\n\n",
 357       scalar @segs);
 358     foreach $seg (@segs) {
 359         $segr= $segs{$seg};
 360
 361         o("static const SegPosCombInfo spci_${seg}"."[]= {");
 362         $delim='';
 363         for ($comb=0; $comb < $segr->{Posns}; $comb++) {
 364             $pi='';
 365             foreach $feat (keys %{ $segr->{Feats} }) {
 366                 $featr= $segr->{Feats}{$feat};
 367                 next if exists $featr->{Fixed};
 368                 $pi.= sprintf("%s%d", $feat,
 369                               ($comb / $featr->{Weight}) % $featr->{Posns});
 370             }
 371             o("$delim\n");
 372             o(sprintf "  { %-8s %4d",
 373               '"'.$seg.(length $pi ? '/' : '').$pi.'",',
 374               $segr->{Dist}[$comb]);
 375             for ($end=0; $end<2; $end++) {
 376                 o(", { ");
 377                 $otherend= $segr->{Ends}[$comb][$end];
 378                 defined $otherend or die "$seg $comb $end ?";
 379                 ($node,$side) = @$otherend;
 380                 $nodeotherside= $nodes{$node}[1-$side];
 381                 if (defined $nodeotherside) {
 382                     $otherseg= $nodeotherside->{Seg};
 383                     $otherbackrelus= $nodeotherside->{End} ^ $end ^ 1;
 384                     o(sprintf "/*%5s.%d %-5s*/ %d,%3d",
 385                       $node,$side,
 386                       ($otherbackrelus?'-':' ').$otherseg,
 387                       $otherbackrelus,
 388                       $segs{$otherseg}{Num});
 389                 } else {
 390                     o(sprintf "/*%5s.%d*/ 0,NOTA(Segment)",
 391                       $node,$side);
 392                 }
 393                 o(" }");
 394             }
 395             o(sprintf " }");
 396             $delim= ',';
 397         }
 398         o("\n};\n");
 399
 400         next unless $segr->{FeatCount};
 401
 402         for $pt (keys %{ $segr->{Feats} }) {
 403             $ptv= $segr->{Feats}{$pt};
 404             next if exists $ptv->{Fixed};
 405             o("static const BoardObject mfbo_${seg}_${pt}"."[]= {");
 406             $delim=' ';
 407             foreach $boob (@{ $ptv->{BoOb} }) {
 408                 o($delim);
 409                 o(so_boob('pt',$boob));
 410                 $delim= ', ';
 411             }
 412             o(" };\n");
 413         }
 414
 415         o("static const MovFeatInfo mfi_${seg}"."[]= {");
 416         $delim='';
 417         for $pt (keys %{ $segr->{Feats} }) {
 418             $ptv= $segr->{Feats}{$pt};
 419             next if exists $ptv->{Fixed};
 420             o("$delim\n");
 421             o("  { \"$seg/$pt\", mfk_".lc($ptv->{Kind}).",".
 422               " $ptv->{Posns}, $ptv->{Weight}, mfbo_${seg}_$pt }");
 423             $delim=',';
 424         }
 425         o("\n};\n");
 426     }
 427     o("const SegmentNum info_nsegments=NUM_SEGMENTS;\n");
 428     o("const SegmentInfo info_segments[NUM_SEGMENTS]= {");
 429     $delim= '';
 430     foreach $seg (@segs) {
 431         $segr= $segs{$seg};
 432         o("$delim\n");
 433         o(sprintf "  { %-7s %d, %2d,%-9s %3d,%-10s %-6s,%-6s }",
 434           "\"$seg\",", $segr->{Inv},
 435           $segr->{FeatCount}, ($segr->{FeatCount} ? "mfi_$seg," : '0,'),
 436           $segr->{Posns}, "spci_$seg,",
 437           so_oboob('sense',$segr),
 438           so_oboob('reverse', $segr->{Inv} ? $segr : undef));
 439         $delim= ',';
 440     }
 441     o("\n};\n");
 442 }
 443
 444 # writeasm_KIND()
 445
 446 sub o_section ($) {
 447     my ($sec) = @_;
 448     o("$sec code ${sec}_start");
 449 }
 450
 451 sub writeasm_sense {
 452     o_section("pindata_pic2detinfo");
 453     o("Exists equ 0x8000\n".
 454       "Detectors equ 0x0080\n".
 455       "Reversers equ 0x0000\n");
 456     for ($num=0; $num<@boardtype; $num++) {
 457         if (!defined $boardtype[$num]) { o(" dw  0\n"); next; }
 458         $base= $sensesbase[$num];
 459         o(sprintf " dw  Exists | %-10s | 0x%02x%02x\n",
 460           ucfirst($boardtype[$num]), $base >> 7, $base & 0x7f);
 461     }
 462     o(sprintf " fill 0, maxboards_count-%d\n", $num);
 463     o("\n");
 464 }
 465
 466 #       for $w (qw(pic port bit)) {
 467 #           @d=();
 468 #           o("\n");
 469 #           o("${k}_${w}_data_section  org  ${k}_${w}_data\n");
 470 #           for ($i=0; $i<@{ $pin_used{$k} }; $i++) {
 471 #               $or= $pin_used{$k}[$i];
 472 #               if (defined $or) {
 473 #                   $or->[1] =~ m/^(\d+)\,\d+,(\w+)$/;
 474 #                   ($portnum,$bit)= ($1,$2);
 475 #                   $portnum= sprintf "%02x", $portnum + 0x89; # 89=LATA
 476 #                   $bit= sprintf "%02x", hex $bit;
 477 #               } else {
 478 #                   $portnum=$bit='00';
 479 #               }
 480 #               if ($w eq 'pic') {
 481 #                   if (defined $or) {
 482 #                       push @d, $or->[0];
 483 #                   } else {
 484 #                       push @d, 'X',
 485 #                   }
 486 #               } elsif ($w eq 'port') {
 487 #                   push @d, $portnum;
 488 #               } elsif ($w eq 'bit') {
 489 #                   push @d, $bit;
 490 #               } else {
 491 #                   die;
 492 #               }
 493 #           }
 494 #           push @d, 'X' if @d^1;
 495 #           @d= map { s/^[a-f]/0$&/; sprintf "%3s", $_ } @d;
 496 #           for (;;) {
 497 #               $d[$each/2] = " $d[$each/2]" if $#d >= $each/2;
 498 #               last if @d <= $each;
 499 #               o("        db      ". join(',',@d[0..($each-1)]). "\n");
 500 #               @d= @d[$each..$#d];
 501 #           }
 502 #           o("        db      ".join(',',@d)."\n");
 503 #           if ($w eq 'pic') {
 504 #               o("        if \$ > ${k}_pic_data + ${k}_num_max\n".
 505 #                 "         error \"too much ${k}_picdata\"\n".
 506 #                 "        endif\n".
 507 #                 "        fill 0xffff, ${k}_pic_data + ${k}_num_max - \$\n");
 508 #           }
 509 #       }
 510 #     }
 511 sub writeasm () {
 512     my ($k,$w,$i,@d,$or,$p,$portnum,$bit,$each);
 513     close STDOUT or die $!;
 514     open STDOUT, ">$basename-pindata.asm" or die $!;
 515     o("; autogenerated - do not edit\n");
 516     o("        include pindata.inc\n".
 517       "        radix dec\n".
 518       "X       equ 0xff\n");
 519     $each= 10;
 520     for $k (@objkinds) {
 521         &{"writeasm_$k"}();
 522     }
 523     o("\n        end\n");
 524 }
 525 mainread();
 526 writeout();
 527 writeasm();