lib/App/Scheme79asm.pm

   1 package App::Scheme79asm;
   2
   3 use 5.014000;
   4 use strict;
   5 use warnings;
   6 use re '/s';
   7 use Carp qw/croak/;
   8
   9 use Data::Dumper qw/Dumper/;
  10 use Data::SExpression qw/consp scalarp/;
  11 use Scalar::Util qw/looks_like_number/;
  12
  13 our $VERSION = '0.005001';
  14
  15 our %TYPES = (
  16         LIST => 0,
  17         SYMBOL => 1,
  18         NUMBER => 1,
  19         VAR => 2,
  20         VARIABLE => 2,
  21         CLOSURE => 3,
  22         PROC => 4,
  23         PROCEDURE => 4,
  24         IF => 5,
  25         COND => 5,
  26         CONDITIONAL => 5,
  27         CALL => 6,
  28         QUOTE => 7,
  29         QUOTED => 7,
  30
  31         MORE => 0,
  32         CAR => 1,
  33         CDR => 2,
  34         CONS => 3,
  35         ATOM => 4,
  36         PROGN => 5,
  37         'REVERSE-LIST' => 6,
  38         FUNCALL => 7,
  39 );
  40
  41 *consp = *Data::SExpression::consp;
  42 *scalarp = *Data::SExpression::scalarp;
  43
  44 sub process {
  45         my ($self, $sexp, $location) = @_;
  46         die 'Toplevel is not a list: ', Dumper($sexp), "\n" unless ref $sexp eq 'ARRAY';
  47         my ($type, @addrs) = @$sexp;
  48         my $addr;
  49
  50         die 'Type of toplevel is not atom: '. Dumper($type), "\n" unless scalarp($type);
  51
  52         if (@addrs > 1) {
  53                 $addr = $self->{freeptr} + 1;
  54                 $self->{freeptr} += @addrs;
  55                 $self->process($addrs[$_], $addr + $_) for 0 .. $#addrs;
  56         } else {
  57                 $addr = $addrs[0];
  58         }
  59
  60         $addr = $self->process($addr) if ref $addr eq 'ARRAY';
  61         die 'Addr of toplevel is not atom: ', Dumper($addr), "\n" unless scalarp($addr);
  62         my ($comment_type, $comment_addr) = ($type, $addr);
  63         die 'Computed addr is not a number: ', Dumper($addr), "\n" unless looks_like_number $addr;
  64
  65         if (!looks_like_number $type) {
  66                 die "No such type: $type\n" unless exists $TYPES{$type};
  67                 $type = $TYPES{$type};
  68         }
  69
  70         $addr += (1 << $self->{addr_bits}) if $addr < 0;
  71         die "Type too large: $type\n" if $type >= (1 << $self->{type_bits});
  72         die "Addr too large: $addr\n" if $addr >= (1 << $self->{addr_bits});
  73         my $result = ($type << $self->{addr_bits}) + $addr;
  74
  75         unless ($location) {
  76                 $self->{freeptr}++;
  77                 $location = $self->{freeptr}
  78         }
  79         $self->{memory}[$location] = $result;
  80         $self->{comment}[$location] = "$comment_type $comment_addr";
  81         $location
  82 }
  83
  84 sub parse {
  85         my ($self, $string) = @_;
  86         my $ds = Data::SExpression->new({symbol_case => 'up', use_symbol_class => 1, fold_lists => 1});
  87
  88         my $sexp;
  89         while () {
  90                 last if $string =~ /^\s*$/;
  91                 ($sexp, $string) = $ds->read($string);
  92                 $self->process($sexp)
  93         }
  94 }
  95
  96 sub finish {
  97         my ($self) = @_;
  98         $self->{memory}[5] = $self->{memory}[$self->{freeptr}];
  99         $self->{comment}[5] = $self->{comment}[$self->{freeptr}];
 100         $self->{memory}[4] = $self->{freeptr};
 101         delete $self->{memory}[$self->{freeptr}]
 102 }
 103
 104 sub new {
 105         my ($class, %args) = @_;
 106         $args{type_bits} //= 3;
 107         $args{addr_bits} //= 8;
 108         $args{freeptr} //= 6;
 109         $args{memory} //= [0, 0, (1<<$args{addr_bits}), (1<<$args{addr_bits}), 0, 0, 0];
 110         my @default_comments = ('(cdr part of NIL)', '(car part of NIL)', '(cdr part of T)', '(car part of T)', '(free storage pointer)', '', '(result of computation)');
 111         for (0 .. $#default_comments) {
 112                 $args{comment}[$_] = $default_comments[$_]
 113         }
 114         bless \%args, $class
 115 }
 116
 117 sub print_binary16 {
 118         my ($self, $fh) = @_;
 119         $fh //= \*STDOUT; # uncoverable condition right
 120
 121         die "addr_bits + type_bits >= 16\n"if $self->{addr_bits} + $self->{type_bits} > 16;
 122
 123         my $length = @{$self->{memory}};
 124         print $fh pack 'n', $length or croak "Failed to print memory size: $!"; # uncoverable branch true
 125         for (@{$self->{memory}}) {
 126                 print $fh pack 'n', $_ or croak "Failed to print memory: $!" # uncoverable branch true
 127         }
 128 }
 129
 130 sub print_verilog {
 131         my ($self, $fh) = @_;
 132         $fh //= \*STDOUT; # uncoverable condition right
 133
 134         my $bits = $self->{type_bits} + $self->{addr_bits};
 135         my $index_length = length $#{$self->{memory}};
 136         my $index_format = '%' . $index_length . 'd';
 137         for my $index (0 .. $#{$self->{memory}}) {
 138                 my $val = $self->{memory}[$index];
 139                 my $comment = $self->{comment}[$index];
 140                 if ($index == 4) {
 141                         $val = "${bits}'d$val"
 142                 } else {
 143                         $val = $val ? sprintf "%d'b%0${bits}b", $bits, $val : '0';
 144                 }
 145                 my $spaces = ' ' x ($bits + 5 - (length $val));
 146                 $index = sprintf $index_format, $index;
 147
 148                 my $string = "mem[$index] <= $val;";
 149                 $string .= "$spaces // $comment" if defined $comment;
 150                 say $fh $string or croak "Failed to print verilog: $!"; # uncoverable branch true
 151         }
 152
 153 }
 154 sub parse_and_print_binary16 {
 155         my ($self, $string, $fh) = @_;
 156         $self->parse($string);
 157         $self->finish;
 158         $self->print_binary16($fh);
 159 }
 160
 161 sub parse_and_print_verilog {
 162         my ($self, $string, $fh) = @_;
 163         $self->parse($string);
 164         $self->finish;
 165         $self->print_verilog($fh);
 166 }
 167
 168 1;
 169 __END__
 170
 171 =encoding utf-8
 172
 173 =head1 NAME
 174
 175 App::Scheme79asm - assemble sexp to Verilog ROM for SIMPLE processor
 176
 177 =head1 SYNOPSIS
 178
 179   use App::Scheme79asm;
 180   my $asm = App::Scheme79asm->new(type_bits => 3, addr_bits => 5);
 181   $asm->parse_and_print_verilog('(number 70)');
 182
 183 =head1 DESCRIPTION
 184
 185 SIMPLE is a LISP processor defined in the 1979
 186 B<Design of LISP-Based Processors> paper by Steele and Sussman.
 187
 188 The SIMPLE processor expects input in a particular tagged-pointer
 189 format. This module takes a string containing a sequence of
 190 S-expressions. Each S-expression is a list of one of three types:
 191
 192 C<(tag value)>, for example C<(symbol 2)>, represents a value to be
 193 put in memory (for example a number, or a symbol, or a variable
 194 reference). The value must be a number.
 195
 196 C<(tag list)>, where C<list> is of one of these three types,
 197 represents a tagged pointer. In this case, C<list> is (recursively)
 198 laid out in memory as per these rules, and a pointer to that location
 199 (and tagged C<tag>) is put somewhere in memory.
 200
 201 C<(tag list1 list2)>, where C<list1> and C<list2> are of one of these
 202 three types (not necessarily the same type). In this case, C<list1>
 203 and C<list2> are (recursively) laid out in memory such that C<list1>
 204 is at position X and C<list2> is at position X+1, and a pointer of
 205 type tag and value X is put somewhere in memory.
 206
 207 After this process the very last pointer placed in memory is moved to
 208 the special location 5 (which is where SIMPLE expects to find the
 209 expression to be evaluated).
 210
 211 In normal use a single S-expression will be supplied, representing an
 212 entire program.
 213
 214 The C<tag> is either a number, a type, or a primitive.
 215 The available types are:
 216
 217 =over
 218
 219 =item LIST
 220
 221 =item SYMBOL (syn. NUMBER)
 222
 223 =item VAR (syn. VARIABLE)
 224
 225 =item CLOSURE
 226
 227 =item PROC (syn. PROCEDURE)
 228
 229 =item IF (syn. COND, CONDITIONAL)
 230
 231 =item CALL
 232
 233 =item QUOTE (syn. QUOTED)
 234
 235 =back
 236
 237 The available primitives are:
 238
 239 =over
 240
 241 =item MORE
 242
 243 =item CAR
 244
 245 =item CDR
 246
 247 =item CONS
 248
 249 =item ATOM
 250
 251 =item PROGN
 252
 253 =item REVERSE-LIST
 254
 255 =item FUNCALL
 256
 257 =back
 258
 259 The following methods are available:
 260
 261 =over
 262
 263 =item App::Scheme79asm->B<new>([key => value, key => value, ...])
 264
 265 Create a new assembler object. Takes a list of keys and values, here
 266 are the possible keys:
 267
 268 =over
 269
 270 =item type_bits
 271
 272 =item address_bits
 273
 274 A word is made of a type and an address, with the type occupying the
 275 most significant C<type_bits> (default 3) bits, and the address
 276 occupying the least significant C<address_bits> (default 8) bits.
 277 Therefore the word size is C<type_bits + address_bits> (default 11).
 278
 279 =item freeptr
 280
 281 A pointer to the last used byte in memory (default 6). The program
 282 will be laid out starting with location C<freeptr + 1>.
 283
 284 =item memory
 285
 286 The initial contents of the memory. Note that locations 4, 5, 6 will
 287 be overwritten, as will every location larger than the value of
 288 C<freeptr>.
 289
 290 =item comment
 291
 292 The initial comments for memory entries. C<< $comment->[$i] >> is the
 293 comment for C<< $memory->[$i] >>. Note that the first 7 entries of
 294 this array will be overwritten with the default comments. This is
 295 useful when using custom initial memory contents and freeptr, because
 296 this key can be used to provide comments for the extra reserved
 297 locations in memory.
 298
 299 =back
 300
 301 =item $asm->B<parse>(I<$string>)
 302
 303 Parse a sequence of S-expressions and lay it out in memory.
 304 Can be called multiple times to lay out multiple sequences of
 305 S-expressions one after another.
 306
 307 =item $asm->B<process>(I<$sexp>)
 308
 309 Given an already-parsed sexp (meaning a
 310 L<Data::SExpression> object), lay it out in memory.
 311 Can be called multiple times to lay out multiple sequences of
 312 S-expressions one after another.
 313
 314 =item $asm->B<finish>
 315
 316 Move the last pointer to position 5, and put the free pointer at
 317 position 4. After all sequences of S-expressions have been given to
 318 B<parse>, this method should be called.
 319
 320 =item $asm->B<print_binary16>([I<$fh>])
 321
 322 Print the length of the memory (as a big-endian 16-bit value),
 323 followed by the memory contents as a sequence of big-endian 16-bit
 324 values to the given filehandle (default STDOUT). Dies if
 325 C<addr_bits + type_bits> is more than 16.
 326
 327 Big-endian 16-bit values can be decoded with C<unpack 'n', $value>.
 328
 329 =item $asm->B<print_verilog>([I<$fh>])
 330
 331 Print a block of Verilog code assigning the memory contents to an
 332 array named C<mem> to the given filehandle (default STDOUT).
 333
 334 =item $asm->B<parse_and_print_binary16>(I<$string>[, I<$fh>])
 335
 336 Convenience method that calls B<parse>($string), B<finish>, and then
 337 B<print_binary16>($fh).
 338
 339 =item $asm->B<parse_and_print_verilog>(I<$string>[, I<$fh>])
 340
 341 Convenience method that calls B<parse>($string), B<finish>, and then
 342 B<print_verilog>($fh).
 343
 344 =back
 345
 346 =head1 SEE ALSO
 347
 348 L<http://repository.readscheme.org/ftp/papers/ai-lab-pubs/AIM-514.pdf>
 349
 350 =head1 AUTHOR
 351
 352 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 353
 354 =head1 COPYRIGHT AND LICENSE
 355
 356 Copyright (C) 2018 by Marius Gavrilescu
 357
 358 This library is free software; you can redistribute it and/or modify
 359 it under the same terms as Perl itself, either Perl version 5.24.3 or,
 360 at your option, any later version of Perl 5 you may have available.
 361
 362
 363 =cut