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