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