From 445e5104bd8af5e68f5176a049daebae4216e352 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 17 Jul 2021 01:15:48 +0800 Subject: [PATCH 1/4] Introduce a delegation The 'translate' method now calls 'do_translate', which is the abstract method that the deriving classes override. --- lib/Language/Bel/Compiler/Pass.pm | 10 ++++++++-- lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm | 3 ++- lib/Language/Bel/Compiler/Pass/Alpha.pm | 3 ++- lib/Language/Bel/Compiler/Pass/Flatten.pm | 3 ++- 4 files changed, 14 insertions(+), 5 deletions(-) diff --git a/lib/Language/Bel/Compiler/Pass.pm b/lib/Language/Bel/Compiler/Pass.pm index 6653e089..a6d4c648 100644 --- a/lib/Language/Bel/Compiler/Pass.pm +++ b/lib/Language/Bel/Compiler/Pass.pm @@ -12,13 +12,19 @@ sub new { }, $class); } -# abstract sub translate { + my ($self, $program) = @_; + + return $self->do_translate($program); +} + +# @abstract +sub do_translate { my ($self) = @_; my $name = $self->{name}; - die "The [$name] pass doesn't implement a 'translate' method"; + die "The [$name] pass doesn't implement a 'do_translate' method"; } 1; diff --git a/lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm b/lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm index d2dbba94..ec17d057 100644 --- a/lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm +++ b/lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm @@ -42,7 +42,8 @@ sub substitute_registers { } } -sub translate { +# @override +sub do_translate { my ($self, $ast) = @_; $ast = cdr($ast); diff --git a/lib/Language/Bel/Compiler/Pass/Alpha.pm b/lib/Language/Bel/Compiler/Pass/Alpha.pm index 2af70df9..56eb31fa 100644 --- a/lib/Language/Bel/Compiler/Pass/Alpha.pm +++ b/lib/Language/Bel/Compiler/Pass/Alpha.pm @@ -48,7 +48,8 @@ sub replace_variables { } } -sub translate { +# @override +sub do_translate { my ($self, $ast) = @_; $ast = cdr($ast); diff --git a/lib/Language/Bel/Compiler/Pass/Flatten.pm b/lib/Language/Bel/Compiler/Pass/Flatten.pm index 97b700ce..5ffad457 100644 --- a/lib/Language/Bel/Compiler/Pass/Flatten.pm +++ b/lib/Language/Bel/Compiler/Pass/Flatten.pm @@ -135,7 +135,8 @@ sub listify { return $list; } -sub translate { +# @override +sub do_translate { my ($self, $ast) = @_; $ast = cdr($ast); From cbc825bf2a1598b566691e52ad79391250aabba1 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 17 Jul 2021 01:51:15 +0800 Subject: [PATCH 2/4] Introduce check_precondition All the preconditions pass, but I'm going to let that slide for now. Soon enough, these will get tested in a natural way as the compiler passes evolve. --- lib/Language/Bel/Compiler/Pass.pm | 6 ++++++ .../Bel/Compiler/Pass/AllocateRegisters.pm | 5 +++++ lib/Language/Bel/Compiler/Pass/Alpha.pm | 17 ++++++++++++----- lib/Language/Bel/Compiler/Pass/Flatten.pm | 14 ++++++++++++++ 4 files changed, 37 insertions(+), 5 deletions(-) diff --git a/lib/Language/Bel/Compiler/Pass.pm b/lib/Language/Bel/Compiler/Pass.pm index a6d4c648..7871a49d 100644 --- a/lib/Language/Bel/Compiler/Pass.pm +++ b/lib/Language/Bel/Compiler/Pass.pm @@ -15,9 +15,15 @@ sub new { sub translate { my ($self, $program) = @_; + $self->check_precondition($program); + return $self->do_translate($program); } +sub check_precondition { + # do nothing by default +} + # @abstract sub do_translate { my ($self) = @_; diff --git a/lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm b/lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm index ec17d057..ad5ad44f 100644 --- a/lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm +++ b/lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm @@ -42,6 +42,11 @@ sub substitute_registers { } } +# @override +sub check_precondition { + # no checks +} + # @override sub do_translate { my ($self, $ast) = @_; diff --git a/lib/Language/Bel/Compiler/Pass/Alpha.pm b/lib/Language/Bel/Compiler/Pass/Alpha.pm index 56eb31fa..f5e70a38 100644 --- a/lib/Language/Bel/Compiler/Pass/Alpha.pm +++ b/lib/Language/Bel/Compiler/Pass/Alpha.pm @@ -48,6 +48,18 @@ sub replace_variables { } } +# @override +sub check_precondition { + my ($self, $ast) = @_; + + my $args = car(cdr(cdr($ast))); + + die "Not general enough to handle these args yet: ", _print($args) + unless is_pair($args) + && is_symbol(car($args)) + && is_nil(cdr($args)); +} + # @override sub do_translate { my ($self, $ast) = @_; @@ -58,11 +70,6 @@ sub do_translate { $ast = cdr($ast); my $args = car($ast); - die "Not general enough to handle these args yet: ", _print($args) - unless is_pair($args) - && is_symbol(car($args)) - && is_nil(cdr($args)); - my $single_param_name = symbol_name(car($args)); my $gensym = make_symbol(gensym()); diff --git a/lib/Language/Bel/Compiler/Pass/Flatten.pm b/lib/Language/Bel/Compiler/Pass/Flatten.pm index 5ffad457..e88299f6 100644 --- a/lib/Language/Bel/Compiler/Pass/Flatten.pm +++ b/lib/Language/Bel/Compiler/Pass/Flatten.pm @@ -135,6 +135,20 @@ sub listify { return $list; } +# @override +sub check_precondition { + my ($self, $ast) = @_; + + my $body = cdr(cdr(cdr($ast))); + + while (!is_nil($body)) { + my $statement = car($body); + die "Can't handle 'if' statements just yet" + if is_pair($statement) && is_symbol_of_name(car($statement), "if"); + $body = cdr($body); + } +} + # @override sub do_translate { my ($self, $ast) = @_; From d6afea4861f043911be48eca998a1b14233e2727 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Sat, 24 Jul 2021 00:49:09 +0800 Subject: [PATCH 3/4] Introduce check_postcondition --- lib/Language/Bel/Compiler/Gensym.pm | 9 +- lib/Language/Bel/Compiler/Pass.pm | 8 +- .../Bel/Compiler/Pass/AllocateRegisters.pm | 119 ++++++++++++++++++ lib/Language/Bel/Compiler/Pass/Alpha.pm | 49 ++++++++ lib/Language/Bel/Compiler/Pass/Flatten.pm | 99 +++++++++++++++ 5 files changed, 281 insertions(+), 3 deletions(-) diff --git a/lib/Language/Bel/Compiler/Gensym.pm b/lib/Language/Bel/Compiler/Gensym.pm index ae1c43cd..003d8d40 100644 --- a/lib/Language/Bel/Compiler/Gensym.pm +++ b/lib/Language/Bel/Compiler/Gensym.pm @@ -19,12 +19,17 @@ sub gensym { return $GENSYM_PREFIX . sprintf("%04d", ++$unique_gensym_index); } +sub starts_with { + my ($string, $prefix) = @_; + + return substr($string, 0, length($prefix)) eq $prefix; +} + sub is_gensym { my ($expr) = @_; return is_symbol($expr) - && substr(symbol_name($expr), 0, length($GENSYM_PREFIX)) - eq $GENSYM_PREFIX; + && starts_with(symbol_name($expr), $GENSYM_PREFIX); } our @EXPORT_OK = qw( diff --git a/lib/Language/Bel/Compiler/Pass.pm b/lib/Language/Bel/Compiler/Pass.pm index 7871a49d..f51d4473 100644 --- a/lib/Language/Bel/Compiler/Pass.pm +++ b/lib/Language/Bel/Compiler/Pass.pm @@ -16,14 +16,20 @@ sub translate { my ($self, $program) = @_; $self->check_precondition($program); + my $result = $self->do_translate($program); + $self->check_postcondition($result); - return $self->do_translate($program); + return $result; } sub check_precondition { # do nothing by default } +sub check_postcondition { + # do nothing by default +} + # @abstract sub do_translate { my ($self) = @_; diff --git a/lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm b/lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm index ad5ad44f..b7b45f35 100644 --- a/lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm +++ b/lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm @@ -6,10 +6,16 @@ use strict; use warnings; use Language::Bel::Core qw( + is_nil is_pair is_symbol + is_symbol_of_name make_pair make_symbol + symbol_name +); +use Language::Bel::Printer qw( + _print ); use Language::Bel::Compiler::Gensym qw( is_gensym @@ -42,6 +48,21 @@ sub substitute_registers { } } +sub starts_with { + my ($string, $prefix) = @_; + + return substr($string, 0, length($prefix)) eq $prefix; +} + +my $REGISTER_PREFIX = "%"; + +sub is_register { + my ($expr) = @_; + + return is_symbol($expr) + && starts_with(symbol_name($expr), $REGISTER_PREFIX); +} + # @override sub check_precondition { # no checks @@ -65,4 +86,102 @@ sub do_translate { ); } +# @override +sub check_postcondition { + my ($self, $ast) = @_; + + my $body = cdr(cdr($ast)); + + while (!is_nil($body)) { + die "body not a pair" + unless is_pair($body); + + my $operation = car($body); + + my @operands; + while (!is_nil($operation)) { + die "operation is not a pair" + unless is_pair($operation); + push @operands, car($operation); + $operation = cdr($operation); + } + + my $op_name = shift(@operands); + + if (is_symbol_of_name($op_name, "return")) { + die "expected gensym as only operand to 'return'" + unless scalar(@operands) == 1 && is_register($operands[0]); + } + elsif (is_register($op_name)) { + die "expected two operands" + unless scalar(@operands) == 2; + die "expected := immediately after gensym" + unless is_pair($operands[0]) + && is_symbol_of_name(car($operands[0]), "compose") + && is_symbol_of_name(car(cdr($operands[0])), "="); + + my $rhs = $operands[1]; + my @rhs_operands; + while (!is_nil($rhs)) { + die "rhs operation is not a pair" + unless is_pair($rhs); + push @rhs_operands, car($rhs); + $rhs = cdr($rhs); + } + + my $rhs_op = shift(@rhs_operands); + + if (is_pair($rhs_op) + && is_symbol_of_name(car($rhs_op), "prim") + && is_pair(car(cdr($rhs_op))) + && is_symbol_of_name(car(car(cdr($rhs_op))), "quote") + && is_symbol(car(cdr(car(cdr($rhs_op)))))) { + + my $primop_name = symbol_name(car(cdr(car(cdr($rhs_op))))); + + die "expected primop to be id or type" + unless $primop_name eq "id" || $primop_name eq "type"; + + if ($primop_name eq "id") { + die "expected prim!id to have 2 operands" + unless scalar(@rhs_operands) == 2; + + die "expected first prim!id operand to be a register" + unless is_register($rhs_operands[0]); + + die "expected second prim!id operand to be a quoted symbol" + unless is_pair($rhs_operands[1]) + && is_symbol_of_name(car($rhs_operands[1]), "quote") + && is_symbol(car(cdr($rhs_operands[1]))); + } + elsif ($primop_name eq "type") { + die "expected prim!type to have 1 operand" + unless scalar(@rhs_operands) == 1; + + die "expected prim!type operand to be a register" + unless is_register($rhs_operands[0]); + } + else { + die "unexpected type of primop: $primop_name"; + } + } + elsif (is_symbol_of_name($rhs_op, "quote")) { + die "expected quote to have 1 operand" + unless scalar(@rhs_operands) == 1; + + die "expected quote operand to be a symbol" + unless is_symbol($rhs_operands[0]); + } + else { + die "unexpected rhs"; + } + } + else { + die "unrecognized operation: ", _print(car($body)); + } + + $body = cdr($body); + } +} + 1; diff --git a/lib/Language/Bel/Compiler/Pass/Alpha.pm b/lib/Language/Bel/Compiler/Pass/Alpha.pm index f5e70a38..1e94da2e 100644 --- a/lib/Language/Bel/Compiler/Pass/Alpha.pm +++ b/lib/Language/Bel/Compiler/Pass/Alpha.pm @@ -9,6 +9,7 @@ use Language::Bel::Core qw( is_nil is_pair is_symbol + is_symbol_of_name make_pair make_symbol symbol_name @@ -23,6 +24,7 @@ use Language::Bel::Compiler::Primitives qw( ); use Language::Bel::Compiler::Gensym qw( gensym + is_gensym ); sub new { @@ -94,4 +96,51 @@ sub do_translate { ); } +# @override +sub check_postcondition { + my ($self, $ast) = @_; + + my $args = car(cdr(cdr($ast))); + my $body = cdr(cdr(cdr($ast))); + + assure_meets_postcondition($body); +} + +sub is_among_symbol_names { + my ($value, @names) = @_; + + for my $name (@names) { + return 1 + if is_symbol_of_name($value, $name); + } + return ''; +} + +sub assure_meets_postcondition { + my ($value) = @_; + + if (is_nil($value)) { + return; + } + elsif (is_pair($value) && is_symbol_of_name(car($value), "quote")) { + return; + } + elsif (is_pair($value)) { + assure_meets_postcondition(car($value)); + assure_meets_postcondition(cdr($value)); + } + elsif (is_gensym($value)) { + return; + } + elsif (is_among_symbol_names($value, "id", "type")) { + return; + } + elsif (is_symbol_of_name($value, "no")) { + return; # XXX: should be generalized to "known globals" + } + else { + die "Doesn't meet precondition: '", _print($value), "'"; + } +} + 1; diff --git a/lib/Language/Bel/Compiler/Pass/Flatten.pm b/lib/Language/Bel/Compiler/Pass/Flatten.pm index e88299f6..ba6bfb47 100644 --- a/lib/Language/Bel/Compiler/Pass/Flatten.pm +++ b/lib/Language/Bel/Compiler/Pass/Flatten.pm @@ -23,6 +23,7 @@ use Language::Bel::Reader qw( ); use Language::Bel::Compiler::Gensym qw( gensym + is_gensym ); use Language::Bel::Compiler::Primitives qw( car @@ -186,4 +187,102 @@ sub do_translate { ); } +# @override +sub check_postcondition { + my ($self, $ast) = @_; + + my $body = cdr(cdr($ast)); + + while (!is_nil($body)) { + die "body not a pair" + unless is_pair($body); + + my $operation = car($body); + + my @operands; + while (!is_nil($operation)) { + die "operation is not a pair" + unless is_pair($operation); + push @operands, car($operation); + $operation = cdr($operation); + } + + my $op_name = shift(@operands); + + if (is_symbol_of_name($op_name, "return")) { + die "expected gensym as only operand to 'return'" + unless scalar(@operands) == 1 && is_gensym($operands[0]); + } + elsif (is_gensym($op_name)) { + die "expected two operands" + unless scalar(@operands) == 2; + die "expected := immediately after gensym" + unless is_pair($operands[0]) + && is_symbol_of_name(car($operands[0]), "compose") + && is_symbol_of_name(car(cdr($operands[0])), "="); + + my $rhs = $operands[1]; + my @rhs_operands; + while (!is_nil($rhs)) { + die "rhs operation is not a pair" + unless is_pair($rhs); + push @rhs_operands, car($rhs); + $rhs = cdr($rhs); + } + + my $rhs_op = shift(@rhs_operands); + + if (is_pair($rhs_op) + && is_symbol_of_name(car($rhs_op), "prim") + && is_pair(car(cdr($rhs_op))) + && is_symbol_of_name(car(car(cdr($rhs_op))), "quote") + && is_symbol(car(cdr(car(cdr($rhs_op)))))) { + + my $primop_name = symbol_name(car(cdr(car(cdr($rhs_op))))); + + die "expected primop to be id or type" + unless $primop_name eq "id" || $primop_name eq "type"; + + if ($primop_name eq "id") { + die "expected prim!id to have 2 operands" + unless scalar(@rhs_operands) == 2; + + die "expected first prim!id operand to be a gensym" + unless is_gensym($rhs_operands[0]); + + die "expected second prim!id operand to be a quoted symbol" + unless is_pair($rhs_operands[1]) + && is_symbol_of_name(car($rhs_operands[1]), "quote") + && is_symbol(car(cdr($rhs_operands[1]))); + } + elsif ($primop_name eq "type") { + die "expected prim!type to have 1 operand" + unless scalar(@rhs_operands) == 1; + + die "expected prim!type operand to be a gensym" + unless is_gensym($rhs_operands[0]); + } + else { + die "unexpected type of primop: $primop_name"; + } + } + elsif (is_symbol_of_name($rhs_op, "quote")) { + die "expected quote to have 1 operand" + unless scalar(@rhs_operands) == 1; + + die "expected quote operand to be a symbol" + unless is_symbol($rhs_operands[0]); + } + else { + die "unexpected rhs"; + } + } + else { + die "unrecognized operation: ", _print(car($body)); + } + + $body = cdr($body); + } +} + 1; From 1468a7d9841428ef82ceb61f96a9117c62379e38 Mon Sep 17 00:00:00 2001 From: Carl Masak Date: Wed, 6 Oct 2021 11:41:15 +0800 Subject: [PATCH 4/4] Rename pass No need to use two words. --- lib/Language/Bel/Compiler.pm | 4 ++-- .../Bel/Compiler/Pass/{AllocateRegisters.pm => Allocate.pm} | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) rename lib/Language/Bel/Compiler/Pass/{AllocateRegisters.pm => Allocate.pm} (98%) diff --git a/lib/Language/Bel/Compiler.pm b/lib/Language/Bel/Compiler.pm index d613dc01..05c0f66f 100644 --- a/lib/Language/Bel/Compiler.pm +++ b/lib/Language/Bel/Compiler.pm @@ -4,7 +4,7 @@ use 5.006; use strict; use warnings; -use Language::Bel::Compiler::Pass::AllocateRegisters; +use Language::Bel::Compiler::Pass::Allocate; use Language::Bel::Compiler::Pass::Alpha; use Language::Bel::Compiler::Pass::Flatten; use Language::Bel::Compiler::Generator qw( @@ -22,7 +22,7 @@ sub make_pass { my @PASSES = map { make_pass($_) } qw< Alpha Flatten - AllocateRegisters + Allocate >; sub compile { diff --git a/lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm b/lib/Language/Bel/Compiler/Pass/Allocate.pm similarity index 98% rename from lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm rename to lib/Language/Bel/Compiler/Pass/Allocate.pm index b7b45f35..0e3d403c 100644 --- a/lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm +++ b/lib/Language/Bel/Compiler/Pass/Allocate.pm @@ -1,4 +1,4 @@ -package Language::Bel::Compiler::Pass::AllocateRegisters; +package Language::Bel::Compiler::Pass::Allocate; use base qw(Language::Bel::Compiler::Pass); use 5.006;