Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Initial revision

git-svn-id: https://svn.parrot.org/parrot/trunk@1852 d31e2699-5ff4-0310-a27c-f18f2fbe73fe
  • Loading branch information...
commit 9b3438cb93460118fef0de8adb6d97fa1d6eadb1 1 parent 928ec7a
Dan Sugalski authored
View
24 languages/perl6/MANIFEST
@@ -0,0 +1,24 @@
+mkdistro.sh
+README
+MANIFEST
+Makefile
+t/parser/exe2.t
+t/parser/P6CTest.pm
+t/parser/exe4.t
+t/parser/exe3.t
+t/parser/README
+t/parser/basic.t
+t/parser/similar.t
+t/compiler/1.t
+t/compiler/2.t
+t/compiler/3.t
+t/compiler/4.t
+prd-perl6.pl
+P6C/Builtins.pm
+P6C/IMCC.pm
+P6C/Nodes.pm
+P6C/Tree.pm
+P6C/Util.pm
+P6C/Parser.pm
+P6C/Addcontext.pm
+P6C/Context.pm
View
21 languages/perl6/Makefile
@@ -0,0 +1,21 @@
+compile=perl prd-perl6.pl --batch --imc
+imcc=../languages/imcc/imcc
+asm=perl ../assemble.pl
+
+all:
+
+test:
+ perl t/*/*.t
+
+%.pasm: %.imc
+ $(imcc) $< $@
+
+%.imc: %.p6
+ $(compile) < $< > $@
+
+%.pbc: %.pasm
+ $(asm) $< > $@
+
+.PRECIOUS: %.imc %.pasm
+
+.PHONY: all test
View
589 languages/perl6/P6C/Addcontext.pm
@@ -0,0 +1,589 @@
+=head1 Addcontext
+
+This file contains the code to propagate context, using the following
+node functions:
+
+=over
+
+=item B<ctx_right($node, $ctx)>
+
+Called when C<$node> appears in right-hand context C<$ctx>.
+C<ctx_right> should propagate the appropriate context to child nodes.
+
+=item B<ctx_left($node, $other, $ctx)>
+
+Called when C<$node> appears as the lvalue in an expression whose
+rvalue is C<$other>, and whose context is C<$ctx>. C<$other> may be
+C<undef> if the rvalue is not known, such as when C<$node> is a member
+of a tuple to which an array is being assigned (e.g. C<($a, $node) =
+@some_things>). If C<$other> is defined, C<ctx_left> should call its
+C<ctx_right> method with the appropriate context. Otherwise, it
+should return the desired right context.
+
+=back
+
+This file also defines the contexts for built-in increment, binary,
+and unary operators, and for "magic" things like guards and C<loop>.
+
+=cut
+
+use P6C::Context;
+use P6C::Nodes;
+use P6C::Util qw(:all);
+use strict;
+
+BEGIN { # Add types for builtin binary operators.
+ # types for symmetric operators:
+ # type => [list-of-ops].
+ my %opmap =
+ ( # Ops that work differently for different scalar types:
+ PerlUndef => [ qw(| & ~ // ..),
+ # Unfortunately, these work differently on ints and nums:
+ qw(+ - * / % **)],
+
+ PerlInt => [ qw(<< >>) ],
+
+ PerlString => [ qw(_) ],
+
+ # NOTE: Actually, according to apo 3, boolean operators
+ # propagate values in their surrounding context (even though
+ # they may evaluate in boolean context?). So we can't quite
+ # do this.
+# bool => [ qw(&& ~~ ||) ],
+ );
+
+ while (my ($t, $ops) = each %opmap) {
+ my $ctx = new P6C::Context type => [$t, $t];
+ my @opnames = map { "infix $_" } @$ops;
+ @P6C::Context::CONTEXT{@opnames} = ($ctx) x @opnames;
+ }
+
+ # Ill-behaved operators.
+ $P6C::Context::CONTEXT{'infix x'} = new P6C::Context
+ type => [undef, 'PerlInt'];
+}
+
+sub P6C::Binop::ctx_left {
+ # comma expression as lvalue => tuple context. Gather types from
+ # constituent expressions, then propagate this context to the
+ # right.
+ my ($x, $other, $ctx) = @_;
+ unless ($x->op eq ',') {
+ die "Operator ".$x->op." can't appear in left context.";
+ }
+
+ # NOTE: we can't split whatever's on the other side into a tuple,
+ # so we just pass undef to subparts. Some things, like the
+ # ternary, lose at this point.
+ my @subctx = map { $_->ctx_left(undef, $ctx) } $x->flatten_leftop(',');
+ my $right_ctx = new P6C::Context type => [@subctx];
+ if (defined $other) {
+ $other->ctx_right($right_ctx);
+ } else {
+ return $right_ctx;
+ }
+}
+
+sub P6C::Binop::ctx_right {
+ my ($x, $ctx) = @_;
+ my $op = $x->op;
+ if (ref($op) && $op->isa('P6C::hype')) {
+ # XXX: do we need to propagate hyper context? This might be
+ # useful for coalescing sequences of hyper-ops. For now, just
+ # ignore it.
+ my $newctx = new P6C::Context;
+ $x->l->ctx_right($newctx);
+ $x->r->ctx_right($newctx);
+
+ } elsif ($op eq '=') {
+ # Special-case assignment operator to enforce context l -> r
+ # XXX: not sure what to do with +=, etc.
+
+ # Propagate context:
+ $x->l->ctx_left($x->r, $ctx);
+ # give incoming context to left side
+ $x->l->ctx_right($ctx);
+
+ } elsif ($op eq ',') {
+ # List of items.
+ # XXX: this is gross.
+ my @things = $x->flatten_leftop(',');
+ my $vl = P6C::ValueList->new(vals => \@things);
+ $vl->ctx_right($ctx);
+
+ } elsif (exists $P6C::Context::CONTEXT{"infix $op"}) {
+ # This operator determines context for its operands.
+ my ($ltype, $rtype) = @{$P6C::Context::CONTEXT{"infix $op"}->type};
+ my $opctx = $ctx->copy;
+ $opctx->type($ltype);
+ $x->l->ctx_right($opctx);
+ $opctx->type($rtype);
+ $x->r->ctx_right($opctx);
+
+ } else {
+ # We know nothing about the context. Say so, and propagate
+ # the surrounding context.
+ diag "No context information for `infix $op'";
+ my $opctx = new P6C::Context;
+ $x->l->ctx_right($opctx);
+ $x->r->ctx_right($opctx);
+ }
+
+ # Store away our context.
+ $x->{ctx} = $ctx->copy;
+}
+
+##############################
+sub P6C::sv_literal::ctx_right {
+ my ($x, $ctx) = @_;
+ $x->{ctx} = $ctx->copy;
+}
+
+##############################
+sub P6C::variable::ctx_right {
+ my ($x, $ctx) = @_;
+ $x->{ctx} = $ctx->copy;
+}
+
+sub P6C::variable::ctx_left {
+ # XXX: not sure what to do about left-side '*' operator, so we
+ # just ignore it.
+ my ($x, $other, $ctx) = @_;
+
+ my $newctx = new P6C::Context type => $x->type,
+ flatten => ($x->type eq 'PerlArray');
+
+ if (defined $other) {
+ $other->ctx_right($newctx);
+ } else {
+ return $newctx;
+ }
+}
+
+##############################
+sub P6C::indices::ctx_right {
+ my ($x, $ctx) = @_;
+
+# Indices take their context's arity from the outer context, but its
+# type from the index type. For example, in C<(str $a, num $b) =
+# @x[1,2]>, the outer context is C<[str, int]>, the index type is
+# C<PerlArray>, and the resulting indexing context is C<[int, int]>.
+
+# Arrays are always integer-indexed. Hashes are currently
+# string-indexed. If that changes to PMC's change this.
+ my %indextype = qw(PerlHash str
+ PerlArray int);
+ my $index_ctx;
+ if ($ctx->is_tuple) {
+
+ $index_ctx = new P6C::Context
+ type => [($indextype{$x->type}) x @{$ctx->type}];
+
+ } elsif ($ctx->is_scalar || $ctx->type eq 'void') {
+ # XXX: this causes problems with things like C<$x = @a[@i]>.
+ # I don't know what that should do.
+ $index_ctx = new P6C::Context type => [$indextype{$x->type}];
+
+ } elsif ($ctx->is_array) {
+ $index_ctx = new P6C::Context type => 'PerlArray';
+
+ } else {
+ use Data::Dumper;
+ use Carp 'confess';
+ confess "index contest: ", Dumper($ctx);
+ }
+
+ $x->indices->ctx_right($index_ctx);
+
+ # unused for now. This could be used to fix the scalar indexing
+ # problem above.
+ $x->{ctx} = $ctx->copy;
+}
+
+sub P6C::indices::ctx_left {
+ my ($x, $other, $ctx) = @_;
+
+ die "indices::ctx_left called with other" if $other;
+
+ # Now figure out context for RHS.
+ my $rctx = new P6C::Context;
+
+ if ($x->indices->isa('P6C::sv_literal')
+ || ($x->indices->isa('P6C::variable')
+ && is_scalar($x->indices->type))) {
+ # Scalar expression. Note that this misses a lot of things.
+ $rctx->type('PerlUndef');
+ $x->indices->ctx_right(new P6C::Context type => $x->type);
+
+ } elsif ($x->indices->isa('P6C::Binop') && $x->op eq ',') {
+ # tuple => propagate arity to other side.
+ my @things = $x->indices->flatten_leftop(',');
+ $rctx->type([('PerlUndef') x @things]);
+ $x->indices->ctx_right(new P6C::Context
+ type => [($x->type) x @things]);
+
+ } else {
+ # Indexing by something else => fallback to array.
+ $rctx->type('PerlArray');
+ $x->indices->ctx_right(new P6C::Context type => 'PerlArray');
+ }
+
+ return $rctx;
+}
+
+##############################
+sub P6C::subscript_exp::ctx_right {
+ my ($x, $ctx) = @_;
+ if (@{$x->subscripts} > 1) {
+ # XXX: shouldn't be too hard -- just evaluate subscripts right
+ # to left. I think all the intermediates will be indexed in
+ # scalar context, but I'm not quite sure.
+ unimp "multi-level subscripting";
+ }
+ my $index = $x->subscripts(0);
+ # The base variable is indexed as a $index->type, so give it that
+ # context.
+ $x->thing->ctx_right(new P6C::Context type => $index->type);
+
+ # Propagate context to indices as well. For the moment, they just
+ # use the index arity.
+ $index->ctx_right($ctx);
+
+ $x->{ctx} = $ctx->copy;
+}
+
+sub P6C::subscript_exp::ctx_left {
+ my ($x, $other, $ctx) = @_;
+ if (@{$x->subscripts} > 1) {
+ # XXX: shouldn't be too hard -- just evaluate subscripts
+ # recursively on temporaries. Not sure how context would work.
+ unimp "multi-level subscripting";
+ }
+ my $index = $x->subscripts(0);
+
+ # XXX: what's the context for the base variable? There should be
+ # some way to indicate that it's in lvalue context. For now,
+ # evaluate it in right context with a type corresponding to the
+ # kind of indices we're using.
+ $x->thing->ctx_right(new P6C::Context type => $index->type);
+
+
+ my $rctx = $index->ctx_left(undef, $ctx);
+
+ $x->{ctx} = $ctx;
+
+ if (defined $other) {
+ $other->ctx_right($rctx);
+ } else {
+ return $rctx;
+ }
+}
+
+##############################
+BEGIN {
+ # Context here is somewhat bogus, partly because the variable is
+ # in lvalue context, and partly because ++ and -- are overloaded
+ # like mad.
+ my $ctx = new P6C::Context type => 'PerlUndef';
+ $P6C::Context::CONTEXT{'++'}
+ = $P6C::Context::CONTEXT{'suffix ++'}
+ = $P6C::Context::CONTEXT{'--'}
+ = $P6C::Context::CONTEXT{'suffix --'}
+ = $ctx;
+}
+
+sub P6C::incr::ctx_right {
+ my ($x, $ctx) = @_;
+ if (ref($x->op)) {
+ die;
+ } else {
+ my $name = $x->post ? 'suffix '.$x->op : $x->op;
+ my $subcontext = $P6C::Context::CONTEXT{$name};
+ if ($subcontext) {
+ $x->thing->ctx_right($subcontext);
+ } else {
+ diag "No context for operator `$name'";
+ }
+ }
+ $x->{ctx} = $ctx->copy;
+}
+
+##############################
+sub ifunless_context {
+ my ($x, $ctx) = @_;
+ my $boolctx = new P6C::Context type => 'bool';
+ foreach (@{$x->args}) {
+ my ($sense, $test, $block) = @$_;
+ $sense ||= $x->name;
+ if (ref $test) {
+ $test->ctx_right($boolctx);
+ }
+ $block->ctx_right($ctx);
+ }
+}
+
+sub for_context {
+ use P6C::Util 'flatten_leftop';
+ my ($x, $ctx) = @_;
+ my ($ary, $body) = @{$x->args->vals};
+ my @streams = flatten_leftop($ary, ';');
+ my @bindings;
+ if ($body->params) {
+ @bindings = flatten_leftop($body->params, ';');
+ if (@bindings > 1 && @bindings != @streams) {
+ die <<'END';
+"for" requires equal number of bindings and streams. e.g.
+ for @a; @b -> $a, $b ; $c { ... }
+not
+ for @a -> $a, $b ; $c { ... }
+END
+
+ }
+ # XXX: what do we do to someone who does "for @xs -> () { ... }"?
+ } else {
+ push @bindings, new P6C::variable(name => '$_',
+ type => 'PerlUndef');
+ $body->params($bindings[0]);
+ }
+ my $streamctx = new P6C::Context type => 'PerlArray', flatten => 1;
+ my @stream_result;
+ for (@streams) {
+ my @things = flatten_leftop($_, ',');
+ my $l = new P6C::ValueList vals => [@things];
+ $l->ctx_right($streamctx);
+ push @stream_result, $l;
+ }
+ $x->args->vals(0, [@stream_result]);
+ # Get the body:
+ $body->ctx_right($ctx);
+}
+
+BEGIN {
+ $P6C::Context::CONTEXT{'-'} = new P6C::Context type => ['PerlUndef'];
+ $P6C::Context::CONTEXT{if}
+ = $P6C::Context::CONTEXT{unless} = \&ifunless_context;
+ $P6C::Context::CONTEXT{'for'} = \&for_context;
+ $P6C::Context::CONTEXT{while}
+ = $P6C::Context::CONTEXT{until} # = \&while_context;
+ = new P6C::Context type => ['bool', 'void'];
+ $P6C::Context::CONTEXT{print1} = new P6C::Context type => ['PerlUndef'];
+# $P6C::Context::CONTEXT{for}
+# = new P6C::Context type => ['PerlArray', 'void'];
+}
+
+# Lookup context for a prefix operator. If the sub hasn't been
+# declared yet, none will be found, so we should treat it as taking
+# C<@_>.
+sub arg_context {
+ my ($name, $ctx) = @_;
+ if (exists $P6C::Context::CONTEXT{$name}) {
+ return $P6C::Context::CONTEXT{$name};
+ }
+ diag 'no context found for ', $name;
+ return $P6C::Context::DEFAULT_ARGUMENT_CONTEXT;
+}
+
+sub P6C::prefix::ctx_right {
+ my ($x, $ctx) = @_;
+ my $proto = arg_context($x->name, $ctx);
+
+ if (ref($proto) eq 'CODE') {
+ # blech.
+ $proto->($x, $ctx);
+ } else {
+ $x->args->ctx_right($proto);
+ }
+
+ $x->{ctx} = $ctx->copy;
+}
+
+##############################
+sub P6C::compare::ctx_right {
+ my ($x, $ctx) = @_;
+ my $lasttype;
+ my $anyscalar = new P6C::Context type => 'PerlUndef';
+ my $seq = $x->seq;
+
+ # If two adjacent ops have the same type, we can be more specific
+ # about the type of the item in between. Otherwise, it's scalar.
+ # The first and last items only participate in one comparison, so
+ # we know their types. This information is not used at the
+ # moment, but it's not too hard to gather, and might be useful in
+ # the future.
+
+ for (my $i = 1; $i < $#{$seq}; $i += 2) {
+ my $op = $seq->[$i];
+ my $type = $P6C::compare::type{$op} or die "No such op: $op";
+ if ($lasttype && $lasttype ne $type) {
+ $seq->[$i - 1]->ctx_right($anyscalar);
+ } else {
+ $seq->[$i - 1]->ctx_right(new P6C::Context type => $type);
+ }
+ $lasttype = $type;
+ }
+ $seq->[-1]->ctx_right(new P6C::Context type => $lasttype);
+ $x->{ctx} = $ctx->copy;
+}
+
+##############################
+sub P6C::ternary::ctx_right {
+ my ($x, $ctx) = @_;
+ $x->if->ctx_right(new P6C::Context type => 'bool');
+ $x->then->ctx_right($ctx);
+ $x->else->ctx_right($ctx);
+ $x->{ctx} = $ctx->copy;
+}
+
+sub P6C::ternary::ctx_left {
+ my ($x, $other, $ctx) = @_;
+
+ # Evaluate test in boolean right context.
+ $x->if->ctx_right(new P6C::Context type => 'bool');
+
+ # The ternary operator can actually have different contexts on
+ # different sides. Need to duplcate $other's op-tree, then
+ # propagate context to each side. Once we have a run-time system
+ # for context, we will be able to do better.
+
+ my $thenctx = $x->then->ctx_left(undef, $ctx);
+ my $elsectx = $x->else->ctx_left(undef, $ctx);
+
+ if (!$thenctx->same($elsectx)) {
+ if (!defined $other) {
+ unimp "Assignment to ternary in too hairy a context.";
+ }
+ my $treecopy;
+ {
+ use Data::Dumper;
+ local $Data::Dumper::Purity = 1;
+ local $Data::Dumper::Terse = 1;
+ local $Data::Dumper::Deepcopy = 1;
+ $treecopy = eval Dumper($other);
+ die "Can't duplicate op-tree: $@" if $@;
+ }
+
+ $x->then->ctx_left($other, $ctx);
+ $x->{then_right} = $other;
+
+ $x->else->ctx_left($treecopy, $ctx);
+ $x->{else_right} = $treecopy;
+ } elsif (defined $other) {
+ # XXX: ctx gets propagated twice to $other, which may cause problems.
+ $x->then->ctx_left($other, $ctx);
+ $x->else->ctx_left($other, $ctx);
+ } else {
+ # No other, and we've already propagated context above.
+ return $thenctx;
+ }
+}
+
+##############################
+sub P6C::decl::ctx_right { }
+
+sub P6C::decl::ctx_left {
+ # XXX: this may not be quite right. If we're declaring a single
+ # item, we create a one-item context. If more, a tuple context.
+ # Problem is, we may have thrown away the parens around the single
+ # item by this point.
+ my ($x, $other, $ctx) = @_;
+ my @ctx = map { $_->type } @{$x->vars};
+ if (@ctx == 1) {
+ my $ctx = new P6C::Context type => $ctx[0];
+ if ($ctx[0] eq 'PerlArray') {
+ $ctx->flatten(1);
+ }
+ $other->ctx_right($ctx);
+ } else {
+ # Tuple.
+ $other->ctx_right(new P6C::Context type => \@ctx);
+ }
+}
+
+##############################
+sub P6C::sub_def::ctx_right {
+ my ($x, $ctx) = @_;
+ if ($ctx->type ne 'void') {
+ unimp 'sub def in non-void context';
+ }
+
+ my $argctx;
+ if (!defined $x->closure->params
+ || !defined $x->closure->params->max) {
+ $argctx = $P6C::Context::DEFAULT_ARGUMENT_CONTEXT;
+ } elsif ($x->closure->params->min != $x->closure->params->max) {
+ # Only support variable number of params if it's zero - Inf.
+ unimp "Unsupported parameter arity: ",
+ $x->closure->params->min . ' - ' . $x->closure->params->max;
+ } else {
+ my @types = map { $_->var->type } @{$x->closure->params->req};
+ $argctx = new P6C::Context type => [@types];
+ }
+ $P6C::Context::CONTEXT{$x->name} = $argctx;
+ $x->closure->ctx_right($ctx);
+}
+
+##############################
+sub P6C::closure::ctx_right {
+ my ($x, $ctx) = @_;
+ if ($ctx->type ne 'void') {
+ unimp 'closure in non-void context';
+ }
+
+ # NOTE: once we get return values in, we're in for serious pain
+ # here, since we have to evaluate the last statement in the
+ # _caller_'s context, which we don't know now.
+ if (defined $x->block) { # real def.
+ my $voidctx = new P6C::Context type => 'void';
+ foreach my $stmt (@{$x->block}) {
+ $stmt->ctx_right($voidctx);
+ }
+ }
+}
+
+##############################
+sub P6C::ValueList::ctx_right {
+ my ($x, $ctx) = @_;
+
+ if ($ctx->is_tuple) {
+ my $min = @{$ctx->type} < @{$x->vals} ? @{$ctx->type} : @{$x->vals};
+ for my $i (0 .. $min - 1) {
+ $x->vals($i)->ctx_right(new P6C::Context type => $ctx->type->[$i]);
+ }
+ my $voidctx = new P6C::Context type => 'void';
+ for my $i ($min .. $#{$x->vals}) {
+ $x->vals($i)->ctx_right($voidctx);
+ }
+
+ } elsif ($ctx->is_array) {
+ my $actx = new P6C::Context;
+ if ($ctx->flatten) {
+ $actx->type('PerlArray');
+ } else {
+ $actx->type('PerlUndef');
+ }
+ for (@{$x->vals}) {
+ $_->ctx_right($actx);
+ }
+
+ } elsif ($ctx->is_scalar || $ctx->type eq 'void') {
+ my $voidctx = new P6C::Context type => 'void';
+ for my $i (0 .. $#{$x->vals} - 1) {
+ $x->vals($i)->ctx_right($voidctx);
+ }
+ $x->vals->[-1]->ctx_right($ctx);
+
+ } else {
+ use Data::Dumper;
+ unimp "Unrecognized context: ".Dumper($ctx);
+ }
+ $x->{ctx} = $ctx->copy;
+}
+
+##############################
+sub P6C::guard::ctx_right {
+ my ($x, $ctx) = @_;
+ $x->test->ctx_right(new P6C::Context type => 'bool');
+ $x->expr->ctx_right(new P6C::Context type => 'void');
+}
+
+1;
View
48 languages/perl6/P6C/Builtins.pm
@@ -0,0 +1,48 @@
+package P6C::Builtins;
+
+=head1 B<P6C::Builtins>
+
+XXX: Pre-declare functions the hard way. Once IMCC supports more
+opcodes, this (and emit) will become unnecessary, as we can use a
+"header file" to declare builtins in Perl 6 syntax, and add_code to
+supply their function bodies.
+
+=cut
+
+use P6C::Context;
+use P6C::Parser;
+
+sub declare {
+ my $hash = shift;
+ $hash->{print1} = new P6C::IMCC::Sub args => [['PerlUndef', 'a']];
+
+ # XXX: might as well add ourselves to a few other things while
+ # we're at it:
+ $P6C::Context::CONTEXT{print1} = new P6C::Context type => 'PerlUndef';
+ $P6C::Parser::WANT{print1} = 'scalar_expr';
+}
+
+sub add_code {
+ my $funcs = shift;
+ # (see docs above)
+}
+
+sub emit {
+
+print <<'END';
+.emit
+
+print1:
+pushp
+restore P31
+print P31
+print "\n"
+popp
+ret
+
+.eom
+
+END
+
+}
+1;
View
162 languages/perl6/P6C/Context.pm
@@ -0,0 +1,162 @@
+package P6C::Context;
+
+=head1 B<P6C::Context>
+
+Represents a semantic context.
+
+A C<Context> object supports the following operations:
+
+=over
+
+=item B<$x = type($ctx)>
+
+=item B<type($ctx, $x)>
+
+Get or set the context type, which may be either:
+
+=over
+
+=item * a typename (e.g. PerlString or PerlArray)
+
+=item * an array of typenames representing a tuple.
+
+=item * undef, in cases where an operator is overloaded.
+
+It might be useful to allow multidimensional tuples by making the
+definition recursive, i.e. allowing the type to be an array of
+C<Context>s rather than typenames. It would also be good to get rid
+of the third by handling overloading.
+
+An item evaluate in C<PerlArray> context B<must> return an array --
+doing otherwise leads to a propagation of ugly special cases, and
+breaks flattening horribly.
+
+=back
+
+=item B<$x = flatten($ctx)>
+
+=item B<flatten($ctx, $x)>
+
+Get or set the flattening property, corresponding to the C<*> prefix
+operator. Flattening contexts are also created implicitly in a number
+of places, such as when passing parameters to a sub with no parameter
+list, and when assigning to an array.
+
+When a context is "flattening", its elements are evaluated in
+PerlArray context, and the results are concatenated. This is
+wasteful, as it builds up a temporary array for each item. It would
+be more efficient to have each element just append its results to the
+final array, but this is harder.
+
+=item B<$x = hype($ctx)>
+
+=item B<hype($ctx, $x)>
+
+Get or set hyper-operating context property, corresponding to a C<^>
+on an adjacent operator. Currently unused, as it's easier to just
+brute-force hyper-operation during code generation.
+
+=item B<nelem($ctx)>
+
+Return the number of items wanted in $ctx. For scalars, one, for
+arrays, C<undef>, for lists/tuples, the number of elements in the
+tuple.
+
+=item B<is_scalar($ctx)>
+
+=item B<is_tuple($ctx)>
+
+=item B<is_array($ctx)>
+
+True if the type($ctx) is some kind of scalar, tuple, or array.
+
+=item B<copy($ctx)>
+
+Return a copy of C<$ctx>.
+
+=item B<same($ctx, $ctx2)>
+
+Return true if C<$ctx> and C<$ctx> are "the same".
+
+=back
+
+C<P6C::Context> also defines the following variables:
+
+=over
+
+=item B<$DEFAULT_ARGUMENT_CONTEXT>
+
+Flattening array context corresponding to C<@_> arguments to subs with
+no parameter declaration.
+
+=item B<%CONTEXT>
+
+The hash C<%P6C::Context::CONTEXT> maps operator names to C<Context>s
+or, in a few messy cases, code refs. Infix and suffix operators are
+named "infix X" and "suffix X" where C<X> is the operator symbol. The
+messy cases include things like C<if>, which don't play well with our
+current notion of context. I'm not sure C<if> can ever really be
+handled in a standard way, since it takes an arbitrary number of
+parameters of particular types.
+
+=back
+
+=cut
+
+use strict;
+use P6C::Util qw(diag unimp same_type);
+use Class::Struct P6C::Context => { qw(type $ flatten $ hype $) };
+
+our %CONTEXT;
+
+our $DEFAULT_ARGUMENT_CONTEXT;
+
+BEGIN {
+ $DEFAULT_ARGUMENT_CONTEXT
+ = new P6C::Context type => 'PerlArray', flatten => 1;
+}
+
+sub nelem {
+ my $ctx = shift->type;
+ if (!ref($ctx)) {
+ return scalar_type($ctx) ? 1 : undef;
+ }
+ return @$ctx;
+}
+
+sub is_scalar {
+ my $ctx = shift;
+ my $type = $ctx->type;
+ use P6C::Util;
+ return !ref($type) && !$ctx->flatten && P6C::Util::is_scalar($type);
+}
+
+sub is_tuple {
+ my $type = shift->type;
+ return ref($type) eq 'ARRAY';
+}
+
+sub is_array {
+ my $type = shift->type;
+ return $type eq 'PerlArray';
+}
+
+sub copy {
+ my $x = shift;
+ return bless { %$x }, ref $x;
+}
+
+sub same {
+ my ($x, $y) = @_;
+ # XXX: not very good, but conservative.
+
+ # XXX: we may want another function to find the most specific
+ # supertype of $x and $y.
+ if ($x->flatten != $y->flatten
+ || $x->hype != $y->hype) {
+ return undef;
+ }
+ return same_type($x->type, $y->type);
+}
+
+1;
View
1,978 languages/perl6/P6C/IMCC.pm
@@ -0,0 +1,1978 @@
+=head1 B<P6C::IMCC>
+
+IMCC.pm is still a "ball of mud" at the moment, but context
+propagation has been moved to Context.pm. Next for refactoring is
+symbol handling.
+
+Context should not be propagated during code generation, as the
+context propagation pass handles this. This rule is broken for
+hyper-operators, since I can't think of a good way to handle them
+using context.
+
+Code is generated by a depth-first recursive traversal of the op tree.
+Each node type should define a C<val> function to be called by its
+parent node. This function should gather values from child nodes (by
+calling their C<val> functions), then emit the code for the node's
+operation (using C<P6C::Compiler::code>). Code is appended to the
+current function in the order in which it is generated, so subnodes
+must be evaluated in the proper order.
+
+C<val> should return one of the following:
+
+=over
+
+=item * undef if the node has no rvalue.
+
+=item * a reference to an array of registers if called in tuple
+context.
+
+=item * the name of a PMC register holding the rvalue otherwise.
+
+=back
+
+Node types that can act as lvalues should define an C<assign> function
+that takes an unevaluated rvalue tree and a context structure. This
+function should return a PMC register or array ref (like C<val>) if
+(like an assignment) it serves as both an lvalue and an rvalue.
+
+=head2 External interface
+
+If C<P6C::IMCC> is imported with the ":external" flag, it will define
+the following interface, used by the driver:
+
+=over
+
+=item B<init()>
+
+Initialize or reset compiler state. This should be called before
+generating any code. C<init> destroys all functions and globals,
+resets the current function, and reinitializes builtins.
+
+=item B<compile($top)>
+
+Compile a tree based at $top, but do not emit any code.
+
+=item B<emit()>
+
+Emit IMCC code on standard output, including a header that calls
+C<main>, and the code for any builtin functions (see
+C<P6C::Builtins>). C<emit> will fail if you have not defined C<main>.
+
+=back
+
+=cut
+
+package P6C::IMCC;
+use strict;
+use P6C::Builtins;
+use P6C::Util;
+use P6C::Context;
+
+# Map Perl types to IMCC parameter types:
+my %paramtype = (int => 'int',
+ str => 'string',
+ num => 'float');
+# Map Perl types to Parrot register types:
+my %regtype = (int => 'I',
+ str => 'S',
+ num => 'N');
+sub regtype(*) {
+ $regtype{$_[0]} || 'P';
+}
+
+sub paramtype(*) {
+ $paramtype{$_[0]} || $_[0];
+}
+
+sub import {
+ my ($class, $type) = @_;
+ my @syms = qw(globalvar localvar paramvar findvar
+ add_localvar add_param
+ push_scope pop_scope
+ gentmp genlabel newtmp
+ code
+ add_function set_function exists_function_def
+ exists_function_decl set_function_params
+ gen_counted_loop do_scalar_to_array do_flatten_array);
+ my @external = qw(init compile emit);
+ my $caller = caller;
+ no strict 'refs';
+ if ($type eq ':all') {
+ foreach (@syms) {
+ *{$caller . '::' . $_} = \&$_;
+ }
+ } elsif ($type eq ':external') {
+ foreach (@external) {
+ *{$caller . '::' . $_} = \&$_;
+ }
+ }
+ 1;
+}
+
+our $curfunc; # currently compiling function
+our %funcs; # all known functions
+our %globals; # global variables
+
+sub init { # reset state
+ %funcs = ();
+ %globals = ();
+ undef $curfunc;
+ P6C::Builtins::declare(\%funcs);
+}
+
+sub compile { # compile input (don't emit)
+ my $x = shift;
+ my $ctx = new P6C::Context type => 'void';
+ use P6C::Addcontext;
+ if (ref $x eq 'ARRAY') {
+ # propagate context:
+ foreach my $stmt (@$x) {
+ $stmt->ctx_right($ctx);
+ }
+ # generate code:
+ foreach my $stmt (@$x) {
+ $stmt->val;
+ }
+ } else {
+ # probably single stmt.
+ $x->ctx_right($ctx);
+ $x->val;
+ }
+}
+
+sub emit { # emit all code
+ die "Must define main" unless $funcs{main};
+ print <<'END';
+.sub _main
+ call main
+ end
+ ret
+END
+ P6C::Builtins::add_code(\%funcs);
+ while (my ($name, $sub) = each %funcs) {
+ unless($sub->code) {
+ print STDERR "Skipping empty sub $name (builtin or external?)\n";
+ next;
+ }
+ print ".sub $name\n";
+ $sub->emit;
+ }
+ P6C::Builtins::emit;
+}
+
+=head2 Internals
+
+If C<P6C::IMCC> is imported with the ":all" flag, it exports an
+internal interface.
+
+The compiler maintains a "current function" (could be generalized to
+"current scope") in which code is emitted, locals are declared, and
+symbol lookups begin. The following functions manipulate the current
+function context.
+
+=over
+
+=item B<code($x)>
+
+Append IMCC code C<$x> to the current function.
+
+=item B<add_function($name)>
+
+Create a new function stub for C<$name>. If C<$name> exists, it will
+be overwritten.
+
+=item B<exists_function_def($name)>
+
+Return true if function C<$name> is defined (i.e. not just "declared").
+
+=item B<exists_function_decl($name)>
+
+Return true if a stub exists for C<$name>, even if it has no code.
+
+=item B<$oldfunc = set_function($name)>
+
+Set the code insertion point to the end of function C<$name>,
+returning the name of the previously active function. Function
+C<$name> should exist before this is called.
+
+=item B<set_function_params(@params)>
+
+Set the parameter list for the current function. The arguments should
+be a list of C<P6C::param> objects. XXX: there is currently no way to
+handle variable parameter lists. This is a limitation of the current
+parameter-passing scheme, not just this interface.
+
+=back
+
+=cut
+
+sub code { # add code to current function
+ die "Code must live within a function" unless defined $curfunc;
+ $funcs{$curfunc}->code .= join "\n", @_;
+}
+
+sub add_function($) {
+ my $f = shift;
+ if (exists $funcs{$f}) {
+ diag "Redefining function $f";
+ }
+ $funcs{$f} = new P6C::IMCC::Sub;
+ # NOTE: top-level closure will push a scope.
+ 1;
+}
+
+sub exists_function_def($) {
+ my $f = $funcs{+shift};
+ return $f && $f->code;
+}
+
+sub exists_function_decl($) {
+ return $funcs{+shift} ? 1 : 0;
+}
+
+sub set_function($) { # switch to function, returning old one
+ my $func = shift;
+ my $ofunc = $curfunc;
+ $curfunc = $func;
+ return $ofunc;
+}
+
+sub set_function_params {
+ for my $p (@_) {
+ push @{$funcs{$curfunc}->args()},
+ [$p->var->type, $p->var->mangled_name];
+ }
+}
+
+=head2 Name lookup
+
+This is a primitive symbol table. Which is okay, since Parrot doesn't
+have stashes yet. Hopefully the interface will be useful when things
+get more complicated.
+
+=over
+
+=item B<$name = findvar($var)>
+
+=item B<($name, $isglobal) = findvar($var)>
+
+Find variable C<$var>, a C<P6C::variable>, returning a PMC register
+containing its value. Currently C<findvar> looks at the active
+function's parameters, then locals, then globals (which don't exist,
+so it won't find anything there). Returns undef if the variable is
+not found. C<$isglobal> is currently unused.
+
+=item B<$name = globalvar($var)>
+
+Lookup a global variable.
+
+=item B<$name = localvar($var)>
+
+Find local variable C<$var>, returning its IMCC name.
+
+=item B<$name = paramvar($var)>
+
+Find parameter C<$var>.
+
+=item B<add_localvar($var)>
+
+Declare local variable C<$var>. Warns if C<$var> is already defined.
+If C<$var-E<gt>type> is a PMC type, C<$var> will automatically be
+initialized.
+
+=item B<push_scope()>
+
+Push a scope within the current function.
+
+=item B<pop_scope()>
+
+Pop a scope from the current function.
+
+=back
+
+=cut
+
+sub globalvar($) {
+ # Globals always exist...
+ # except when they don't
+ unimp 'No globals yet';
+ my $name = shift->mangled_name;
+ $globals{$name} ||= 1;
+ $name;
+}
+
+sub localvar($) {
+ my $var = shift;
+
+ die "Local variable outside function" unless defined $curfunc;
+ return $funcs{$curfunc}->localvar($var);
+}
+
+sub add_localvar($) {
+ return $funcs{$curfunc}->add_localvar(@_);
+}
+
+sub paramvar($) {
+ my $var = shift->mangled_name;
+ return $var if grep {
+ $_->[1] eq $var;
+ } @{$funcs{$curfunc}->args};
+ return undef;
+}
+
+sub findvar($) {
+ my ($var) = @_;
+ my $name;
+ $name = paramvar($var) || localvar($var) || globalvar($var);
+ return wantarray ? ($name, 0) : $name;
+}
+
+sub push_scope {
+ $funcs{$curfunc}->push_scope;
+}
+
+sub pop_scope {
+ $funcs{$curfunc}->pop_scope;
+}
+
+=head2 Temporary names
+
+=over
+
+=item C<gensym([$str])>
+
+Generate a unique identifier. If C<$str> is given, include it as part
+of the identifier.
+
+=item C<genlabel([$str])>
+
+Generate a unique label containing C<$str>.
+
+=item C<newtmp([$type])>
+
+Create a new temporary register to hold a value of type C<$type>,
+which should be "int", "num", "str", or some PMC type. If C<$type> is
+a PMC type, the register will be initialized with a new value. If
+C<$type> is omitted, it default to C<PerlUndef>.
+
+=item C<gentmp([$type])>
+
+Generate an uninitialized temporary register.
+
+=back
+
+=cut
+
+my $lastsym = 0;
+my $lasttmp = 0;
+my $lastlabel = 0;
+sub gensym(;*) {
+ 'S'.$_[0] . ++$lastsym
+}
+
+sub _gentmp(*) { # uninitialized temporary (internal)
+ '$' . $_[0] . ++$lasttmp
+}
+
+sub gentmp(;*) { # uninitialized temporary
+ _gentmp(regtype($_[0] || 'PerlUndef'));
+}
+
+sub genlabel(;$) { # new label (optionally annotated)
+ 'L_'.$_[0]. ++$lastlabel
+}
+
+sub newtmp(;*) { # initialized temporary
+ my $type = shift || 'PerlUndef';
+ my $reg = regtype $type;
+ my $name;
+ if ($reg eq 'S') {
+ $name = _gentmp S;
+ code(<<END);
+ $name = ""
+END
+ } elsif ($reg eq 'I' || $reg eq 'N') {
+ $name = _gentmp $reg;
+ code(<<END);
+ $name = 0
+END
+ } else {
+ $name = _gentmp P;
+ die unless $type;
+ use Carp;
+ code(<<END);
+ $name = new $type
+END
+ }
+ return $name;
+}
+
+=head2 Code generation functions
+
+=over
+
+The following functions generate useful and common pieces of code.
+
+=item B<gen_counted_loop($counter, $body)>
+
+Generate a counted loop using C<$counter> as the repetition count.
+The loop will iterate over values between 0 and $counter - 1,
+inclusive. C<$counter> will be used as the iteration variable, so it
+can be used in indexing expressions in the loop body.
+
+=item B<do_scalar_to_array($val)>
+
+Emit the code to turn a scalar into a one-element array, returning the
+array's name.
+
+=item B<do_flatten_array($vals)>
+
+Emit code to evaluate each item in C<@$vals>, which are assumed to be
+in list context. The results are concatenated into a single array,
+whose name is returned.
+
+=back
+
+=cut
+
+sub gen_counted_loop {
+ my ($count, $body) = @_;
+ my $start = genlabel;
+ my $end = genlabel;
+ return <<END;
+$start: if $count == 0 goto $end
+ dec $count
+ $body
+ goto $start
+$end:
+END
+}
+
+sub do_scalar_to_array {
+ my $x = shift;
+ my $a = newtmp 'PerlArray';
+ code(<<END);
+ $a = 1
+ $a\[0] = $x
+END
+ return $a;
+}
+
+sub do_flatten_array {
+ my $vals = shift;
+ my $tmp = newtmp 'PerlArray';
+ my $len = gentmp 'int';
+ my $offset = gentmp 'int';
+ my $tmpindex = gentmp 'int';
+ my $ptmp = newtmp 'PerlUndef';
+ code(<<END);
+# START array flattening.
+ $offset = 0
+END
+ for my $i (0..$#{$vals}) {
+ my $item = $vals->[$i]->val;
+ code(<<END);
+ $len = $item
+END
+ code(gen_counted_loop($len, <<END));
+ $ptmp = $item\[$len]
+ $tmpindex = $offset + $len
+ $tmp\[$tmpindex] = $ptmp
+END
+ code(<<END);
+ $len = $item
+ $offset = $offset + $len
+END
+ }
+ code("# END array flattening\n");
+ return $tmp;
+}
+
+=head2 P6C::IMCC::Sub
+
+Stores IMCC code for a subroutine.
+
+XXX: the fact that e.g. C<P6C::prefix> relies on this for argument
+information is just wrong. This information should be retrieved from
+the parse tree structures instead.
+
+=over
+
+=item B<code($sub)>
+
+The code (not including C<.local> definitions, etc). Can be appended
+to like C<$func->code .= $thing>.
+
+=item B<emit($sub)>
+
+Emit a complete function body, minus the C<.sub> directive.
+
+=back
+
+=cut
+
+package P6C::IMCC::Sub;
+use Class::Struct P6C::IMCC::Sub
+ => { code => '$', # function body (w/o decls and initialization)
+ scopes => '@', # scope stack
+ args => '@' # arguments, in order passed
+ };
+# {scopelevel} # current scope number
+# {oldscopes} # other closed scopes in this sub.
+
+use P6C::Util 'diag';
+
+sub localvar {
+ my ($x, $var) = @_;
+ my $name = $var->mangled_name;
+ for (@{$x->scopes}) {
+ if (exists $_->{$name}) {
+ return $_->{$name}[0];
+ }
+ }
+ return undef;
+}
+
+sub add_localvar {
+ my ($x, $var) = @_;
+ my $name = $var->mangled_name;
+ my $scopename = $name.$x->{scopelevel};
+ if ($x->scopes->[0]{$name}) {
+ diag 'Redeclaring lexical '.$var->name." in $curfunc";
+ }
+ $x->scopes->[0]{$name} ||= [$scopename, $var->type];
+ return $scopename;
+}
+
+sub push_scope {
+ my $x = shift;
+ $x->{scopelevel}++;
+ unshift @{$x->scopes}, { };
+}
+
+sub pop_scope {
+ my $x = shift;
+ push @{$x->{oldscopes}}, shift @{$x->scopes};
+}
+
+sub code : lvalue {
+ my $x = shift;
+ $x->{code};
+}
+
+sub emit {
+ my $x = shift;
+ print <<END;
+ saveall
+# Parameters:
+END
+ foreach (@{$x->args}) {
+ my ($t, $pname) = @$_;
+ my $ptype = P6C::IMCC::paramtype($t);
+ print <<END;
+ .param $ptype $pname
+END
+ }
+ print "# Named locals:\n";
+ for (@{$x->scopes}, @{$x->{oldscopes}}) {
+ for my $v (values %$_) {
+ my ($n, $t) = @$v;
+ print "\t.local $t $n\n";
+ }
+ }
+ # Maybe constructors for locals:
+ for (@{$x->scopes}, @{$x->{oldscopes}}) {
+ for my $v (values %$_) {
+ my ($n, $t) = @$v;
+ next if $t eq '1'; # uninitialized locals
+ print "\t$n = new $t\n"
+ if P6C::IMCC::regtype($t) eq 'P';
+ }
+ }
+ print $x->code;
+ print <<END;
+ restoreall
+ ret
+END
+}
+
+######################################################################
+# Node-type code generation functions
+
+##############################
+package P6C::Register;
+
+sub val {
+ shift->reg;
+}
+
+##############################
+package P6C::ValueList;
+use P6C::IMCC ':all';
+use P6C::Util ':all';
+
+# XXX: ValueList::val returns an array-ref in tuple context. This is
+# inconsistent with other C<val> functions, which all return single
+# values. However, if you're creating a tuple context, you should
+# know what to expect.
+
+sub val {
+ my $x = shift;
+ my $ctx = $x->{ctx};
+
+ if ($ctx->flatten) {
+ # XXX: flatten has to come first.
+ # In flattening context, we have to build a new array out of
+ # the values. All the values should have been evaluated in
+ # array context, so they will all be PerlArrays.
+ return do_flatten_array($x->vals);
+
+ } elsif ($ctx->is_array) {
+ # In array context, the list's value is an array of all its
+ # elements.
+ my $tmp = newtmp 'PerlArray';
+ code("\t$tmp = ".@{$x->vals}."\n");
+ for my $i (0..$#{$x->vals}) {
+ my $item = $x->vals($i)->val;
+ code(<<END);
+ $tmp\[$i] = $item
+END
+ }
+ return $tmp;
+
+ } elsif ($ctx->is_scalar || $ctx->type eq 'void') {
+ # The value of a list in scalar context is its last value, but
+ # we need to evaluate intermediate expressions for possible
+ # side-effects.
+ for (@{$x->vals}[0..$#{$x->vals} - 1]) {
+ $_->val;
+ }
+ return $x->vals($#{$x->vals})->val;
+
+ } elsif ($ctx->is_tuple) {
+ # In N-tuple context, the list's value is its first N elements.
+ my @ret;
+ my $min = @{$x->vals} < $ctx->nelem ? @{$x->vals} : $ctx->nelem;
+ for my $i (0..$min - 1) {
+ $ret[$i] = $x->vals($i)->val;
+ }
+ for my $i ($min .. $#{$x->vals}) {
+ $x->vals($i)->val;
+ }
+ return [@ret];
+
+ } else {
+ use Data::Dumper;
+ unimp "Can't handle context ".Dumper($ctx);
+ }
+}
+
+##############################
+package P6C::Binop;
+use P6C::IMCC ':all';
+use P6C::Util ':all';
+use P6C::Context;
+
+# Create generic code for $a op $b.
+sub simple_binary {
+ my $x = shift;
+ my $ltmp = $x->l->val;
+ my $rtmp = $x->r->val;
+ my $dest = newtmp;
+ my $op = $x->op;
+ code("\t$dest = $ltmp $op $rtmp\n");
+ return $dest;
+}
+
+# XXX: exponentiation in a loop. Will be replaced once IMCC allows more ops.
+sub slow_pow {
+ my $x = shift;
+ my $dest = newtmp;
+ my $lv = $x->l->val;
+ my $rv = $x->r->val;
+ my $cnt = gentmp 'int';
+ code(<<END);
+# POW
+ $dest = 1
+ $cnt = $rv
+END
+ code(gen_counted_loop($cnt, "$dest = $dest * $lv\n"));
+ return $dest;
+}
+
+# '=' assignment op.
+sub do_assign {
+ my $x = shift;
+ return $x->l->assign($x->r);
+}
+
+# short-circuit logical '&&' operator
+sub do_logand {
+ my $x = shift;
+ my $dest = newtmp;
+ my $thenlab = genlabel 'logical_and';
+ my $endlab = genlabel 'logical_and';
+ my $res = $x->l->val;
+ code(<<END);
+ if $res goto $thenlab
+ goto $endlab
+$thenlab:
+END
+ $res = $x->r->val;
+ code(<<END);
+ $dest = $res
+$endlab:
+END
+ return $dest; # will be undef if first failed.
+}
+
+# Short-circuit logical or.
+sub do_logor {
+ my $x = shift;
+ my $dest = newtmp;
+ my $endlab = genlabel 'logical_or';
+ my $res = $x->l->val;
+ code(<<END);
+# LOGICAL OR
+ $dest = $res
+ if $dest goto $endlab
+END
+ $res = $x->r->val;
+ code(<<END);
+ $dest = $res
+# END_LOGICAL_OR
+$endlab:
+END
+ return $dest;
+}
+
+# Definedness test. Result is the first defined value, or undef.
+sub do_defined {
+ my $x = shift;
+ my $val = $x->l->val;
+ my $itmp = gentmp 'int';
+ my $res = newtmp;
+ my $endlab = genlabel 'defined';
+ code(<<END);
+ $res = $val
+ $itmp = defined $res
+ if $itmp goto $endlab
+END
+ $val = $x->r->val;
+ code(<<END);
+ $res = $val
+$endlab:
+END
+ return $res;
+}
+
+# String concatenation
+sub do_concat {
+ # XXX: The PMC concat doesn't seem to work, so we have to go
+ # through strings.
+ my $x = shift;
+ my $lt = gentmp 'str';
+ my $rt = gentmp 'str';
+ my $restmp = gentmp 'str';
+ my $res = newtmp;
+ my $lval = $x->l->val;
+ my $rval = $x->r->val;
+ code(<<END);
+ $lt = $lval
+ $rt = $rval
+ $restmp = $lt . $rt
+ $res = $restmp
+END
+ return $res;
+}
+
+# Handle a comma operator sequence. Just flattens and calls off to
+# C<P6C::ValueList>.
+sub do_array {
+ my $x = shift;
+ use Carp 'cluck';
+ cluck "Should provide context to comma operator" unless $x->{ctx};
+ my @things = flatten_leftop($x, ',');
+ my $vallist = P6C::ValueList->new(vals => \@things);
+ $vallist->{ctx} = $x->{ctx};
+ return $vallist->val;
+}
+
+# 'x' operator. Waiting for IMCC development, since it's just a
+# simple opcode.
+sub do_repeat {
+ unimp 'repeat';
+}
+
+# Binary infix operators.
+our %ops =
+(
+ '+' => \&simple_binary,
+ '-' => \&simple_binary,
+ '*' => \&simple_binary,
+ '/' => \&simple_binary,
+ '%' => \&simple_binary,
+ '**' => \&slow_pow,
+
+ '>>' => \&simple_binary,
+ '<<' => \&simple_binary,
+ '|' => \&simple_binary,
+ '&' => \&simple_binary,
+ '~' => \&simple_binary,
+
+# '_' => \&simple_binary, # PMC concat broken.
+ '_' => \&do_concat,
+ '=' => \&do_assign,
+ '||' => \&do_logor,
+ '&&' => \&do_logand,
+ '~~' => \&simple_binary,
+ '//' => \&do_defined,
+ ',' => \&do_array,
+ 'x' => \&do_repeat,
+ '..' => \&do_range,
+);
+
+sub val {
+ my $x = shift;
+ if (ref($x->op) eq 'P6C::hype') {
+ return do_hyped($x->op->op, $x->l, $x->r);
+ }
+ if ($ops{$x->op}) {
+ return $ops{$x->op}->($x);
+ } elsif($x->op =~ /^([^=]+)=$/ && $ops{$1}) {
+ # Translate assignment operation into a binary operation.
+ # XXX: Context propagation is broken for these, so we won't
+ # ever do this.
+ return $ops{'='}->(new P6C::Binop op => '=', l => $x->l,
+ r => P6C::Binop->new(op => $1, l => $x->l,
+ r => $x->r));
+ } else {
+ unimp $x->op;
+ }
+}
+
+# XXX: We go through typed registers instead of PMC registers for some
+# hyped operators. Not sure if this is a good idea.
+
+our %optype;
+BEGIN {
+ my %opmap = (int => [ qw(>> << | & ~ ~~)],
+ num => [ qw(+ - * / % **)]);
+ while (my ($t, $ops) = each %opmap) {
+ @optype{@$ops} = ($t) x @$ops;
+ }
+}
+
+# Generate the loop body to compute "$targ = $lindex $op $rindex".
+#
+# XXX: may need to re-map op symbols if IMCC and Perl 6 don't agree on
+# them.
+#
+sub simple_hyped {
+ my ($op, $targ, $lindex, $rindex) = @_;
+ my $optype = $optype{$op} or unimp "Can't hype $op yet";
+ my $ltmp = gentmp $optype;
+ my $rtmp = gentmp $optype;
+ my $dest = gentmp $optype;
+ return <<END;
+ $ltmp = $lindex
+ $rtmp = $rindex
+ $dest = $ltmp $op $rtmp
+ $targ = $dest
+END
+}
+
+sub hype_and {
+ my ($op, $targ, $lindex, $rindex) = @_;
+ my $tmp = newtmp;
+ my $middle = genlabel;
+ my $end = genlabel;
+ return <<END;
+ $tmp = $lindex
+ if $tmp goto $middle
+ goto $end
+$middle:
+ $tmp = $rindex
+ $targ = $tmp
+$end:
+END
+}
+
+sub hype_or {
+ my ($op, $targ, $lindex, $rindex) = @_;
+ my $tmp = newtmp;
+ my $end = genlabel;
+ # XXX: targ, lindex, and rindex may be subscripted, so we can't
+ # use them directly in the test.
+ return <<END;
+ $tmp = $lindex
+ if $tmp goto $end
+ $tmp = $rindex
+$end:
+ $targ = $tmp
+END
+}
+
+our %hype_body = ('||' => \&hype_or, '&&' => \&hype_and);
+
+sub hype_body {
+ my $op = $_[0];
+ if (exists $hype_body{$op}) {
+ return $hype_body{$op}->(@_);
+ } else {
+ return simple_hyped(@_);
+ }
+}
+
+# Hyped operations promote a scalar left- or right-hand side to an
+# array. XXX: should probably do context, since a hyper-operator in
+# tuple or scalar context can do less work.
+sub do_hyped {
+ my ($op, $l, $r) = @_;
+ if (is_array_expr($l) && is_array_expr($r)) {
+ return hype_array_array(@_);
+ } elsif (is_array_expr($l)) {
+ return hype_array_scalar(@_);
+ } elsif (is_array_expr($r)) {
+ return hype_scalar_array(@_);
+ } else {
+ diag "Tried to hyper-operate two scalars";
+ return simple_binary(@_);
+ }
+}
+
+# @xs ^op $y
+sub hype_array_scalar {
+ my ($op, $l, $r) = @_;
+ my $lval = $l->val;
+ my $rval = $r->val;
+ my $len = gentmp 'int';
+ my $dest = newtmp 'PerlArray';
+
+ # Initialization code:
+ code(<<END);
+ $len = $lval
+ $dest = $len
+END
+ my $code = hype_body($op, "$dest\[$len]", "$lval\[$len]", $rval);
+ code(gen_counted_loop($len, $code));
+ return $dest;
+}
+
+# $x ^op @ys
+sub hype_scalar_array {
+ my ($op, $l, $r) = @_;
+ my $lval = $l->val;
+ my $rval = $r->val;
+ my $len = gentmp 'int';
+ my $dest = newtmp 'PerlArray';
+
+ # Initializers:
+ code(<<END);
+ $len = $rval
+ $dest = $len
+END
+ my $code = hype_body($op, "$dest\[$len]", $lval, "$rval\[$len]");
+ code(gen_counted_loop($len, $code));
+ return $dest;
+}
+
+# @xs ^op @ys
+#
+# Currently iterates over the number of elements in the _shorter_ of
+# the two arrays, rather than the longer. This is useful for working
+# with infinite lists, but may not be the behavior in the Apocalypses
+# (XXX: check this).
+#
+sub hype_array_array {
+ my ($op, $l, $r) = @_;
+ my $lval = $l->val;
+ my $rval = $r->val;
+ my $llen = gentmp 'int';
+ my $rlen = gentmp 'int';
+
+ my $cntlabel = genlabel;
+ my $dest = newtmp 'PerlArray';
+ my $looptop = genlabel 'hyper';
+ my $loopend = genlabel 'hyper_end';
+
+ # Header to figure out appropriate length.
+ code(<<END);
+ $llen = $lval
+ $rlen = $rval
+ if $llen > $rlen goto $cntlabel
+ $llen = $rlen
+$cntlabel:
+ $dest = $llen
+END
+ my $code
+ = hype_body($op, "$dest\[$rlen]", "$lval\[$rlen]", "$rval\[$rlen]");
+ code(gen_counted_loop($rlen, $code));
+ return $dest;
+}
+
+sub do_range {
+ my $x = shift;
+ my $ctx = $x->{ctx};
+
+ if ($ctx->is_array) {
+ # XXX: no way to clone PMC's so we have to go through
+ # temporaries to create new values.
+ my $ret = newtmp 'PerlArray';
+ my $itmp = gentmp 'int';
+ my $vtmp = gentmp 'int';
+ my $lval = $x->l->val;
+ my $rval = $x->r->val;
+ my $val = newtmp;
+ my $start = genlabel 'range_start';
+ my $end = genlabel 'range_end';
+ code(<<END);
+ $val = $lval
+ $itmp = 0
+$start:
+ if $val > $rval goto $end
+ $vtmp = $val
+ $ret\[$itmp] = $vtmp
+ inc $val
+ inc $itmp
+ goto $start
+$end:
+END
+ return $ret;
+
+ } elsif ($ctx->is_scalar) {
+ # Probably an iterator. Or maybe that's its own context. Not
+ # sure. We lose in any case.
+ unimp "Range in scalar context.";
+
+ } elsif ($ctx->is_tuple) {
+ # generate enough undef's:
+ my @ret;
+ for (@{$ctx->type}) {
+ push @ret, newtmp;
+ }
+ # Figure out endpoints, and jump to the end if we go past the end.
+ my $lval = $x->l->val;
+ my $rval = $x->r->val;
+ my $end = genlabel 'range_end';
+ my $vtmp = gentmp 'int';
+ for my $i (0 .. $#{$ctx->type}) {
+ # XXX: promoting everything to PMC registers.
+ code(<<END);
+ if $lval > $rval goto $end
+ $vtmp = $lval
+ $ret[$i] = $vtmp
+ inc $lval
+END
+ }
+ code(<<END);
+$end:
+END
+ return [@ret];
+
+ } else {
+ use Data::Dumper;
+ unimp "Unsupported range context ".Dumper($ctx->type);
+ }
+}
+
+######################################################################
+package P6C::incr;
+use P6C::IMCC ':all';
+
+our %inplace_op = ('++' => 'inc', '--' => 'dec');
+our %outaplace_op = ('++' => '+ 1', '--' => '- 1');
+
+sub val {
+ my $x = shift;
+ my $ret;
+
+ # XXX: I'm extra-cautious here because we may be incrementing a
+ # temporary, in which case we have to copy it back. If this can
+ # never happen, then the assigns can be removed here.
+
+ # Optimize post-increment in void context to a pre-increment.
+ if ($x->post && !$x->{ctx}->type eq 'void') {
+ my $op = $outaplace_op{$x->op}
+ or die $x->op().' increment not understood';
+ my $val = $x->thing->val;
+ my $tmp = newtmp;
+ my $tmp2 = newtmp;
+ code(<<END);
+ $tmp = $val
+ $tmp2 = $val $op
+END
+ $x->thing->assign(new P6C::Register reg => $tmp2);
+ return $tmp;
+
+ } else {
+ my $op = $inplace_op{$x->op}
+ or die $x->op().' increment not understood';
+ $ret = $x->thing->val;
+ code("\t$op $ret\n");
+ $x->thing->assign(new P6C::Register reg => $ret);
+ return $ret;
+ }
+}
+
+######################################################################
+package P6C::ternary;
+use P6C::IMCC ':all';
+
+# Ternary operator as an r-value. Context-aware.
+sub val {
+ my $x = shift;
+ my $tmp = newtmp;
+ my ($thenlab, $endlab) = (genlabel("ternary_then"),
+ genlabel("ternary_end"));
+ code(<<END);
+# START TERNARY
+END
+ my $ifval = $x->if->val;
+ code(<<END);
+ if $ifval goto $thenlab
+END
+ my $elseval = $x->else->val;
+ code(<<END);
+ $tmp = $elseval
+ goto $endlab
+$thenlab:
+END
+ my $thenval = $x->then->val;
+ code(<<END);
+ $tmp = $thenval
+$endlab:
+# END TERNARY
+END
+ return $tmp;
+}
+
+# Ternary operator as an l-value. Ignores incoming context. However,
+# the r-value to be assigned will be evaluated in the proper context
+# for each branch.
+
+# REMEMBER: since the two branches may have different contexts, they
+# have different op-trees.
+
+# REMEMBER: we haven't always been able to propagate context, so we
+# fall back to just using the same op-tree for both sides.
+sub assign {
+ my ($x, $thing) = @_;
+ my $tmp = newtmp;
+ my ($thenlab, $endlab) = (genlabel("ternary_then"),
+ genlabel("ternary_end"));
+ code(<<END);
+# START TERNARY
+END
+ my $ifval = $x->if->val;
+ code(<<END);
+ if $ifval goto $thenlab
+END
+ my $elseval = $x->else->assign($x->{else_right} || $thing);
+ code(<<END);
+ $tmp = $elseval
+ goto $endlab
+$thenlab:
+END
+ my $thenval = $x->then->assign($x->{then_right} || $thing);
+ code(<<END);
+ $tmp = $thenval
+$endlab:
+# END TERNARY
+END
+ return $tmp;
+}
+
+######################################################################
+sub P6C::sv_literal::val {
+ use P6C::Util ':all';
+
+ my $x = shift;
+ return undef if $x->{ctx}->type && $x->{ctx}->type eq 'void';
+ my $type = $x->type;
+ my $ctx = $x->{ctx};
+
+ # XXX: these are actually _references_. But we don't support them
+ # anyways.
+ die "Don't support ".$type if $type =~ /Perl(Hash|Array)/;
+ my $val = $x->lval;
+ my $ret;
+ if (!$ctx->type
+ || $ctx->type eq 'void'
+ || same_type($ctx->type, $type)
+ || (is_scalar($ctx->type) && is_scalar($type))) {
+ warn "literal in void context" if $ctx->type eq 'void';
+ $ret = newtmp;
+ code(<<END);
+ $ret = $val
+END
+
+ } elsif ($ctx->is_array) {
+ $ret = do_scalar_to_array($val);
+
+ } elsif ($ctx->is_tuple) {
+ $ret = newtmp;
+ code(<<END);
+ $ret = $val
+END
+
+ } else {
+# use Data::Dumper;
+# unimp "Context ", Dumper($ctx);
+ # XXX: bogus
+ $ret = newtmp;
+ code(<<END);
+ $ret = $val
+END
+ }
+ return $ret;
+}
+
+######################################################################
+# Prefix operators (i.e. functions and control structures)
+package P6C::prefix;
+use P6C::IMCC ':all';
+use P6C::Util ':all';
+use P6C::Context;
+
+sub val_noarg {
+ my $block = shift;
+ # XXX: pretend that the block has a no-argument prototype, since
+ # otherwise it will complain. This is the wrong behavior for the
+ # topicalizing control structures, but we don't support them yet,
+ # anyways.
+
+ my $saveparam = $block->params;
+ $block->params(new P6C::params req => [], opt => [], rest => undef);
+ $block->val;
+ $block->params($saveparam);
+}
+
+# if/elsif/elsunless/else sequence
+sub prefix_if {
+ my $x = shift;
+ my $end = genlabel "endif";
+ my $tmp = newtmp;
+ my $nextlab;
+ foreach (@{$x->args}) {
+ my ($sense, $test, $block) = @$_;
+ $sense ||= $x->name;
+ if ($nextlab) {
+ code("$nextlab:\n");
+ }
+ $nextlab = genlabel 'if';
+ if (!ref $test) {
+ val_noarg($block);
+ } else {
+ my $v = $test->val;
+ if ($sense =~ /if$/) { # (els)?if
+ code(<<END);
+ $tmp = ! $v
+ if $tmp goto $nextlab
+END
+ } else { # (els)?unless
+ code(<<END);
+ if $v goto $nextlab
+END
+ }
+ val_noarg($block);
+ code(<<END);
+ goto $end
+END
+ }
+ }
+ code(<<END);
+$nextlab:
+$end: # END OF @{[$x->name]}
+END
+ return undef;
+}
+
+sub common_while {
+ my ($name, $gentest, $genbody) = @_;
+ my $start = genlabel 'start_while';
+ my $end = genlabel 'endwhile';
+ code(<<END);
+$start:
+END
+ my $testval = $gentest->();
+ if ($name eq 'while') {
+ my $startbody = genlabel 'while_body';
+ code(<<END);
+ if $testval goto $startbody
+ goto $end
+$startbody:
+END
+ } else {
+ code(<<END);
+ if $testval goto $end
+END
+ }
+ $genbody->();
+ code(<<END);
+ goto $start
+$end:
+END
+}
+
+sub prefix_while {
+ my $x = shift;
+ my ($test, $body) = ($x->args->vals(0), $x->args->vals(1));
+ common_while($x->name, sub { $test->val }, sub { val_noarg($body) });
+}
+
+# Do a subroutine call.
+#
+# XXX: currently ignores context. We don't have a way of
+# communicating context to functions anyways, so this isn't a problem.
+sub gen_sub_call {
+ my ($x) = @_;
+
+ my $func = $P6C::IMCC::funcs{$x->name};
+ my $args = $x->args->val;
+
+ # Sometimes function arguments are a tuple, sometimes not. Make
+ # things consistent.
+ if (ref($args) ne 'ARRAY') {
+ $args = [$args];
+ }
+ if (@$args != @{$func->args}) {
+ # internal error.
+ die "Wrong number of arguments for ".$x->name.": got ".@$args
+ .", expected ".@{$func->args};
+ }
+
+ foreach (reverse @$args) {
+ code("\t.arg $_\n");
+ }
+ my $name = $x->name;
+ code("\tcall $name\n");
+ return newtmp; # XXX: return values not implemented.
+}
+
+sub prefix_for {
+ my ($x) = @_;
+ # XXX: apo 4 explicitly says this is lazy, but we take a greedy
+ # approach here.
+ my ($streams, $body) = @{$x->args->vals};
+ unless (ref $streams eq 'ARRAY') {
+ use Data::Dumper;
+ die Dumper($streams);
+ }
+ my @bindings = map { [flatten_leftop($_, ',')] }
+ flatten_leftop($body->params, ';');
+ die "for: internal error" unless @bindings == 1 || @bindings == @$streams;
+
+ # XXX: body closure should take care of params, but since we're
+ # faking the scope, we need to handle the params here.
+
+ # XXX: we iterate over the shortest length. Apo 4 doesn't say
+ # anything about this, but it's consistent with what we're doing
+ # for hyperoperators, and all but necessary if we deal with
+ # infinite streams.
+
+ # XXX: There should be a "clean" version for the common case where
+ # we're iterating over one stream.
+
+ push_scope;
+
+ my @vars; # variables to be bound for each iter.
+ print STDERR "for: bindings";
+ for (@bindings) {
+ my @l;
+ for my $v (@$_) {
+ push @l, add_localvar($v);
+ }
+ print STDERR ' '.@l;
+ push @vars, [@l];
+ }
+ print STDERR "\n";
+
+ my @streamvals = map { $_->val } @$streams;
+ print STDERR "for ".@streamvals." streams\n";
+
+ ##############################
+ if (@bindings == 1) {
+ # No semicolons on RHS => alternate across streams:
+ @vars = @{$vars[0]};
+ my $nstreams = @$streams;
+ my $valsrc = newtmp 'PerlArray'; # value streams.
+ my $tmpsrc = newtmp 'PerlUndef'; # temp for stream.
+ my $stream = gentmp 'int'; # index into streams.
+ my $streamoff = gentmp 'int'; # offset within streams.
+ my $streamlen = gentmp 'int'; # length of shortest stream.
+ my $niters = gentmp 'int'; # number of iterations.
+ my $itmp = gentmp 'int';
+ my $loopstart = genlabel 'start_for';
+
+ # Initialization:
+ code(<<END);
+ $stream = 0
+ $streamoff = 0
+ $streamlen = 2000000000
+ $niters = 0
+ $valsrc = $nstreams
+END
+ for my $i (0..$#{$streams}) {
+ my $streamval = $streamvals[$i];
+ my $notless = genlabel;
+ code(<<END);
+ $valsrc\[$i] = $streamval
+ $itmp = $streamval
+ if $itmp > $streamlen goto $notless
+ $streamlen = $itmp
+$notless:
+END
+ }
+
+ # Figure out number of iterations:
+ my $nvars = @vars;
+ code(<<END);
+ $niters = $streamlen * $nstreams
+ $niters = $niters / $nvars
+$loopstart:
+END
+
+ # bind variables:
+ for my $v (@vars) {
+ my $notnext = genlabel;
+ code(<<END);
+ $tmpsrc = $valsrc\[$stream]
+ $v = $tmpsrc\[$streamoff]
+ inc $stream
+ if $stream < $nstreams goto $notnext
+ $stream = 0
+ inc $streamoff
+$notnext:
+END
+ }
+
+ # Loop body:
+ val_noarg($body);
+ code(<<END);
+ dec $niters
+ if $niters > 0 goto $loopstart
+END
+
+ ##############################
+ } else {
+ # Semicolon on RHS => parallel iteration.
+ my $niters = gentmp 'int'; # number of iterations
+ my @streamoff; # offset within each stream.
+ push(@streamoff, gentmp 'int') for @streamvals;
+ my $itmp = gentmp 'int';
+ my $loopstart = genlabel 'start_for';
+ my $notless = genlabel;
+
+ code(<<END);
+ $niters = 2000000000
+END
+ # Figure out how many iterations:
+ for my $i (0 .. $#streamvals) {
+ my $nvars = @{$vars[$i]};
+ code(<<END);
+ $streamoff[$i] = 0
+ $itmp = $streamvals[$i]
+ $itmp = $itmp / $nvars
+ if $itmp > $niters goto $notless
+ $niters = $itmp
+$notless:
+END
+ }
+ code(<<END);
+$loopstart:
+END
+ # Bind variables:
+ for my $i (0 .. $#streamvals) {
+ for my $j (0 .. $#{$vars[$i]}) {
+ code(<<END);
+ $vars[$i][$j] = $streamvals[$i]\[$streamoff[$i]]
+ inc $streamoff[$i]
+END
+ }
+ }
+
+ # Generate loop body:
+ val_noarg($body);
+ code(<<END);
+ dec $niters
+ if $niters > 0 goto $loopstart
+END
+ }
+ pop_scope;
+ return undef;
+}
+
+# unary minus.
+sub prefix_neg {
+ my $x = shift;
+ my $tmp = $x->args->val;
+ my $res = newtmp;
+ code(<<END);
+ $res = - $tmp
+END
+ return $res;
+}
+
+our %prefix_ops =
+(
+ 'if' => \&prefix_if,
+ 'unless' => \&prefix_if,
+ 'while' => \&prefix_while,
+ 'until' => \&prefix_while,
+ 'for' => \&prefix_for,
+ '-' => \&prefix_neg,
+);
+
+sub val {
+ my $x = shift;
+ # XXX: temporary hack.
+ if (exists_function_decl($x->name)) {
+ return gen_sub_call($x, @_);
+ } elsif (exists $prefix_ops{$x->name}) {
+ return $prefix_ops{$x->name}->($x, @_);
+ } else {
+ unimp "Prefix operator ".$x->name();
+ }
+}
+
+######################################################################
+# Guards
+package P6C::guard;
+use P6C::IMCC ':all';
+use P6C::Util 'unimp';
+
+sub guard_if {
+ my $x = shift;
+ my $test = $x->test->val;
+ my $end = genlabel $x->name;
+ if ($x->name eq 'unless') {
+ code(<<END);
+ if $test goto $end
+END
+ } else {
+ my $foo = genlabel;
+ code(<<END);
+ if $test goto $foo
+ goto $end
+$foo:
+END
+ }
+ $x->expr->val;
+ code(<<END);
+$end:
+END
+ return undef;
+}
+
+sub guard_while {
+ my $x = shift;