lib/App/Scheme79asm.pm

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