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