[app-scheme79asm.git] / lib / App / Scheme79asm.pm

package App::Scheme79asm;

use 5.014000;
use strict;
use warnings;
use re '/s';
use Carp qw/croak/;

use Data::Dumper qw/Dumper/;
use Data::SExpression qw/consp scalarp/;
use Scalar::Util qw/looks_like_number/;

our $VERSION = '0.005';

our %TYPES = (
	LIST => 0,
	SYMBOL => 1,
	NUMBER => 1,
	VAR => 2,
	VARIABLE => 2,
	CLOSURE => 3,
	PROC => 4,
	PROCEDURE => 4,
	IF => 5,
	COND => 5,
	CONDITIONAL => 5,
	CALL => 6,
	QUOTE => 7,
	QUOTED => 7,

	MORE => 0,
	CAR => 1,
	CDR => 2,
	CONS => 3,
	ATOM => 4,
	PROGN => 5,
	'REVERSE-LIST' => 6,
	FUNCALL => 7,
);

*consp = *Data::SExpression::consp;
*scalarp = *Data::SExpression::scalarp;

sub process {
	my ($self, $sexp, $location) = @_;
	die 'Toplevel is not a list: ', Dumper($sexp), "\n" unless ref $sexp eq 'ARRAY';
	my ($type, @addrs) = @$sexp;
	my $addr;

	die 'Type of toplevel is not atom: '. Dumper($type), "\n" unless scalarp($type);

	if (@addrs > 1) {
		$addr = $self->{freeptr} + 1;
		$self->{freeptr} += @addrs;
		$self->process($addrs[$_], $addr + $_) for 0 .. $#addrs;
	} else {
		$addr = $addrs[0];
	}

	$addr = $self->process($addr) if ref $addr eq 'ARRAY';
	die 'Addr of toplevel is not atom: ', Dumper($addr), "\n" unless scalarp($addr);
	my ($comment_type, $comment_addr) = ($type, $addr);
	die 'Computed addr is not a number: ', Dumper($addr), "\n" unless looks_like_number $addr;

	if (!looks_like_number $type) {
		die "No such type: $type\n" unless exists $TYPES{$type};
		$type = $TYPES{$type};
	}

	$addr += (1 << $self->{addr_bits}) if $addr < 0;
	die "Type too large: $type\n" if $type >= (1 << $self->{type_bits});
	die "Addr too large: $addr\n" if $addr >= (1 << $self->{addr_bits});
	my $result = ($type << $self->{addr_bits}) + $addr;
	unless ($location) {
		$self->{freeptr}++;
		$location = $self->{freeptr}
	}
	$self->{memory}[$location] = $result;
	$self->{comment}[$location] = "$comment_type $comment_addr";
	$location
}

sub parse {
	my ($self, $string) = @_;
	my $ds = Data::SExpression->new({symbol_case => 'up', use_symbol_class => 1, fold_lists => 1});

	my $sexp;
	while () {
		last if $string =~ /^\s*$/;
		($sexp, $string) = $ds->read($string);
		$self->process($sexp)
	}
}

sub finish {
	my ($self) = @_;
	$self->{memory}[5] = $self->{memory}[$self->{freeptr}];
	$self->{comment}[5] = $self->{comment}[$self->{freeptr}];
	$self->{memory}[4] = $self->{freeptr};
	delete $self->{memory}[$self->{freeptr}]
}

sub new {
	my ($class, %args) = @_;
	$args{type_bits} //= 3;
	$args{addr_bits} //= 8;
	$args{freeptr} //= 6;
	$args{memory} //= [0, 0, (1<<$args{addr_bits}), (1<<$args{addr_bits}), 0, 0, 0];
	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)');
	for (0 .. $#default_comments) {
		$args{comment}[$_] = $default_comments[$_]
	}
	bless \%args, $class
}

sub print_binary16 {
	my ($self, $fh) = @_;
	$fh //= \*STDOUT; # uncoverable condition right

	die "addr_bits + type_bits >= 16\n"if $self->{addr_bits} + $self->{type_bits} > 16;

	my $length = @{$self->{memory}};
	print $fh pack 'n', $length or croak "Failed to print memory size: $!";
	for (@{$self->{memory}}) {
		print $fh pack 'n', $_ or croak "Failed to print memory: $!"
	}
}

sub print_verilog {
	my ($self, $fh) = @_;
	$fh //= \*STDOUT; # uncoverable condition right

	my $bits = $self->{type_bits} + $self->{addr_bits};
	my $index_length = length $#{$self->{memory}};
	my $index_format = '%' . $index_length . 'd';
	for my $index (0 .. $#{$self->{memory}}) {
		my $val = $self->{memory}[$index];
		my $comment = $self->{comment}[$index];
		if ($index == 4) {
			$val = "${bits}'d$val"
		} else {
			$val = $val ? sprintf "%d'b%0${bits}b", $bits, $val : '0';
		}
		my $spaces = ' ' x ($bits + 5 - (length $val));
		$index = sprintf $index_format, $index;

		my $string = "mem[$index] <= $val;";
		$string .= "$spaces // $comment" if defined $comment;
		say $fh $string or croak "Failed to print verilog: $!";
	}

}
sub parse_and_print_binary16 {
	my ($self, $string, $fh) = @_;
	$self->parse($string);
	$self->finish;
	$self->print_binary16($fh);
}

sub parse_and_print_verilog {
	my ($self, $string, $fh) = @_;
	$self->parse($string);
	$self->finish;
	$self->print_verilog($fh);
}

1;
__END__

=encoding utf-8

=head1 NAME

App::Scheme79asm - assemble sexp to Verilog ROM for SIMPLE processor

=head1 SYNOPSIS

  use App::Scheme79asm;
  my $asm = App::Scheme79asm->new(type_bits => 3, addr_bits => 5);
  $asm->parse_and_print_verilog('(number 70)');

=head1 DESCRIPTION

SIMPLE is a LISP processor defined in the 1979
B<Design of LISP-Based Processors> paper by Steele and Sussman.

The SIMPLE processor expects input in a particular tagged-pointer
format. This module takes a string containing a sequence of
S-expressions. Each S-expression is a list of one of three types:

C<(tag value)>, for example C<(symbol 2)>, represents a value to be
put in memory (for example a number, or a symbol, or a variable
reference). The value must be a number.

C<(tag list)>, where C<list> is of one of these three types,
represents a tagged pointer. In this case, C<list> is (recursively)
laid out in memory as per these rules, and a pointer to that location
(and tagged C<tag>) is put somewhere in memory.

C<(tag list1 list2)>, where C<list1> and C<list2> are of one of these
three types (not necessarily the same type). In this case, C<list1>
and C<list2> are (recursively) laid out in memory such that C<list1>
is at position X and C<list2> is at position X+1, and a pointer of
type tag and value X is put somewhere in memory.

After this process the very last pointer placed in memory is moved to
the special location 5 (which is where SIMPLE expects to find the
expression to be evaluated).

In normal use a single S-expression will be supplied, representing an
entire program.

The C<tag> is either a number, a type, or a primitive.
The available types are:

=over

=item LIST

=item SYMBOL (syn. NUMBER)

=item VAR (syn. VARIABLE)

=item CLOSURE

=item PROC (syn. PROCEDURE)

=item IF (syn. COND, CONDITIONAL)

=item CALL

=item QUOTE (syn. QUOTED)

=back

The available primitives are:

=over

=item MORE

=item CAR

=item CDR

=item CONS

=item ATOM

=item PROGN

=item REVERSE-LIST

=item FUNCALL

=back

The following methods are available:

=over

=item App::Scheme79asm->B<new>([key => value, key => value, ...])

Create a new assembler object. Takes a list of keys and values, here
are the possible keys:

=over

=item type_bits

=item address_bits

A word is made of a type and an address, with the type occupying the
most significant C<type_bits> (default 3) bits, and the address
occupying the least significant C<address_bits> (default 8) bits.
Therefore the word size is C<type_bits + address_bits> (default 11).

=item freeptr

A pointer to the last used byte in memory (default 6). The program
will be laid out starting with location C<freeptr + 1>.

=item memory

The initial contents of the memory. Note that locations 4, 5, 6 will
be overwritten, as will every location larger than the value of
C<freeptr>.

=item comment

The initial comments for memory entries. C<< $comment->[$i] >> is the
comment for C<< $memory->[$i] >>. Note that the first 7 entries of
this array will be overwritten with the default comments. This is
useful when using custom initial memory contents and freeptr, because
this key can be used to provide comments for the extra reserved
locations in memory.

=back

=item $asm->B<parse>(I<$string>)

Parse a sequence of S-expressions and lay it out in memory.
Can be called multiple times to lay out multiple sequences of
S-expressions one after another.

=item $asm->B<process>(I<$sexp>)

Given an already-parsed sexp (meaning a
L<Data::SExpression> object), lay it out in memory.
Can be called multiple times to lay out multiple sequences of
S-expressions one after another.

=item $asm->B<finish>

Move the last pointer to position 5, and put the free pointer at
position 4. After all sequences of S-expressions have been given to
B<parse>, this method should be called.

=item $asm->B<print_binary16>([I<$fh>])

Print the length of the memory (as a big-endian 16-bit value),
followed by the memory contents as a sequence of big-endian 16-bit
values to the given filehandle (default STDOUT). Dies if
C<addr_bits + type_bits> is more than 16.

Big-endian 16-bit values can be decoded with C<unpack 'n', $value>.

=item $asm->B<print_verilog>([I<$fh>])

Print a block of Verilog code assigning the memory contents to an
array named C<mem> to the given filehandle (default STDOUT).

=item $asm->B<parse_and_print_binary16>(I<$string>[, I<$fh>])

Convenience method that calls B<parse>($string), B<finish>, and then
B<print_binary16>($fh).

=item $asm->B<parse_and_print_verilog>(I<$string>[, I<$fh>])

Convenience method that calls B<parse>($string), B<finish>, and then
B<print_verilog>($fh).

=back

=head1 SEE ALSO

L<http://repository.readscheme.org/ftp/papers/ai-lab-pubs/AIM-514.pdf>

=head1 AUTHOR

Marius Gavrilescu, E<lt>marius@ieval.roE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2018 by Marius Gavrilescu

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.24.3 or,
at your option, any later version of Perl 5 you may have available.


=cut
Commit	Line	Data
	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