From 08e051cfa36d0365169be8b8ff6c7cf0f70741be Mon Sep 17 00:00:00 2001 From: Stefan O'Rear Date: Mon, 25 Oct 2010 14:28:08 -0700 Subject: [PATCH] Allow regex embedded blocks to be inlined --- src/Metamodel.pm | 25 ++++++++++++++----------- src/Niecza/Actions.pm | 32 +++++++++++++++++++++++++------- src/Op.pm | 20 +++++++++++++++++++- src/Optimizer/Beta.pm | 4 ++-- src/RxOp.pm | 28 ++++++++++------------------ 5 files changed, 70 insertions(+), 39 deletions(-) diff --git a/src/Metamodel.pm b/src/Metamodel.pm index a3a3b7b5..b279cdbb 100644 --- a/src/Metamodel.pm +++ b/src/Metamodel.pm @@ -519,6 +519,16 @@ our %units; return ($self->outer ? $self->outer->find_lex($name) : undef); } + sub delete_lex { my ($self, $name) = @_; + my $l = $self->lexicals->{$name}; + if ($l) { + if ($l->isa('Metamodel::Lexical::Alias')) { $self->delete_lex($l->to) } + else { delete $self->lexicals->{$name} } + } else { + $self->outer && $self->outer->delete_lex($name); + } + } + sub add_my_name { my ($self, $slot, @ops) = @_; $self->lexicals->{$slot} = Metamodel::Lexical::Simple->new(@ops); } @@ -806,21 +816,14 @@ sub Body::begin { $metabody->signature($self->signature); } + if ($self->type && $self->type eq 'regex') { + $metabody->add_my_name('$*/'); + } + pop @opensubs if $self->transparent; my $do = $self->do; - if ($self->signature && @{ $self->signature->params } >= 1 && - $self->signature->params->[0]->slot eq '$¢') { - $metabody->add_my_name('$*/'); - $do = Op::StatementList->new(children => [ - Op::CallSub->new( - invocant => Op::Lexical->new(name => '&infix:<=>'), - args => [ Op::Lexical->new(name => '$*/'), - Op::Lexical->new(name => '$¢') ]), - $do]); - } - $do->begin; $metabody->code($do); diff --git a/src/Niecza/Actions.pm b/src/Niecza/Actions.pm index 9721ac53..2a79c325 100644 --- a/src/Niecza/Actions.pm +++ b/src/Niecza/Actions.pm @@ -306,6 +306,20 @@ sub transparent { my ($cl, $M, $op, %args) = @_; do => $op)) } +sub rxembed { my ($cl, $M, $op, $trans) = @_; + Op::CallSub->new(node($M), + positionals => [ Op::MakeCursor->new(node($M)) ], + invocant => Op::SubDef->new(node($M), + var => $cl->gensym, + once => 1, + body => Body->new( + transparent => $trans, + class => 'rxembedded', + type => 'Sub', + signature => Sig->simple('$¢'), + do => $op))); +} + sub op_for_regex { my ($cl, $M, $rxop) = @_; my @lift = $rxop->oplift; { @@ -334,6 +348,7 @@ sub encapsulate_regex { my ($cl, $M, $rxop, %args) = @_; pre => \@lift, passcut => $args{passcut}, passcap => $args{passcap}, rxop => $nrxop), ltm => $lad, class => 'Regex', type => 'regex', sig => Sig->simple->for_method); + $subop = Op::CallSub->new(node($M), invocant => $subop, positionals => [ Op::MakeCursor->new(node($M)) ]); return RxOp::Subrule->new(regex => $subop, passcap => $args{passcap}, _passcapzyg => $nrxop, _passcapltm => $lad); } @@ -566,6 +581,8 @@ sub metachar__S_Cur_Ly { my ($cl, $M) = @_; my $inv = $M->{embeddedblock}{_ast}->invocant; $inv->body->type('rxembedded'); $inv->body->signature(Sig->simple('$¢')); + $inv->once(1); + $inv = Op::CallSub->new(node($M), invocant => $inv, positionals => [ Op::MakeCursor->new(node($M)) ]); $M->{_ast} = RxOp::VoidBlock->new(block => $inv); } @@ -669,9 +686,8 @@ sub metachar__S_Single_Single { my ($cl, $M) = @_; sub metachar__S_Double_Double { my ($cl, $M) = @_; if (! $M->{quote}{_ast}->isa('Op::StringLiteral')) { - $M->{_ast} = RxOp::VarString->new(thunk => - $cl->transparent($M, $M->{quote}{_ast}, once => 1, sig => - Sig->simple('$¢'), type => 'rxembedded')); + $M->{_ast} = RxOp::VarString->new(ops => + $cl->rxembed($M, $M->{quote}{_ast}, 1)); return; } $M->{_ast} = RxOp::String->new(text => $M->{quote}{_ast}->text, @@ -698,8 +714,8 @@ sub metachar__S_var { my ($cl, $M) = @_; $M->{_ast} = $cl->rxcapturize($M, $cid, $a); return; } - $M->{_ast} = RxOp::VarString->new(thunk => - $cl->transparent($M, $cl->do_variable_reference($M, $M->{variable}{_ast}), once => 1, sig => Sig->simple('$¢'), type => 'rxembedded')); + $M->{_ast} = RxOp::VarString->new(ops => $cl->rxembed($M, + $cl->do_variable_reference($M, $M->{variable}{_ast}, 1))); } sub rxcapturize { my ($cl, $M, $name, $rxop) = @_; @@ -782,7 +798,7 @@ sub assertion__S_name { my ($cl, $M) = @_; name => $name, args => $args); - my $regex = $cl->transparent($M, $callop, sig => Sig->simple('$¢')); + my $regex = $cl->rxembed($M, $callop, 1); $M->{_ast} = RxOp::Subrule->new(regex => $regex); } @@ -817,6 +833,8 @@ sub assertion__S_Cur_Ly { my ($cl, $M) = @_; my $inv = $M->{embeddedblock}{_ast}->invocant; $inv->body->type('rxembedded'); $inv->body->signature(Sig->simple('$¢')); + $inv->once(1); + $inv = Op::CallSub->new(node($M), invocant => $inv, positionals => [ Op::MakeCursor->new(node($M)) ]); $M->{_ast} = RxOp::CheckBlock->new(block => $inv); } @@ -858,7 +876,7 @@ sub mod_internal__S_p6adv { my ($cl, $M) = @_; $v = $v->[0]{_ast}; if ($k eq 'lang') { - $M->{_ast} = RxOp::SetLang->new(expr => $cl->transparent($M, $v, sig => Sig->simple('$¢'))); + $M->{_ast} = RxOp::SetLang->new(expr => $cl->rxembed($M, $v, 1)); } elsif ($k eq 'dba') { UNWRAP: { $v->isa('Op::Paren') && ($v = $v->inside, redo UNWRAP); diff --git a/src/Op.pm b/src/Op.pm index 38882bf4..c99fbfb7 100644 --- a/src/Op.pm +++ b/src/Op.pm @@ -829,7 +829,7 @@ use CgOp; has exports => (isa => 'ArrayRef[Str]', is => 'ro', default => sub { [] }); # Is candidate for beta-optimization. Not compatible with method_too, # proto_too, exports, ltm - has once => (isa => 'Bool', is => 'ro', default => 0); + has once => (isa => 'Bool', is => 'rw', default => 0); sub code { my ($self, $body) = @_; @@ -1005,6 +1005,24 @@ use CgOp; no Moose; } +# the existance of these two complicates cross-sub inlining a bit +{ + package Op::MakeCursor; + use Moose; + extends 'Op'; + + sub code { + my ($self, $body) = @_; + + CgOp::prog( + CgOp::scopedlex('$*/', CgOp::newscalar(CgOp::rxcall('MakeCursor'))), + CgOp::scopedlex('$*/')); + } + + __PACKAGE__->meta->make_immutable; + no Moose; +} + { package Op::RegexBody; use Moose; diff --git a/src/Optimizer/Beta.pm b/src/Optimizer/Beta.pm index be527603..06fa32c1 100644 --- a/src/Optimizer/Beta.pm +++ b/src/Optimizer/Beta.pm @@ -28,7 +28,7 @@ sub run_optree { return unless $op->isa('Op::CallSub') && no_named_params($op); my $inv = $op->invocant; return unless $inv->isa('Op::SubDef') && $inv->once; - my $cbody = $body->lexicals->{$inv->var} or return; + my $cbody = $body->find_lex($inv->var) or return; $cbody = $cbody->body; return unless is_removable_body($cbody); @@ -93,7 +93,7 @@ sub beta_optimize { # the function my @args = map { [ $_, Niecza::Actions->gensym ] } @{ $op->positionals }; - delete $body->lexicals->{$inv->var}; + $body->delete_lex($inv->var); $unit->xref->[$cbody->xref->[1]] = undef; my @pos = (map { Op::Lexical->new(name => $_->[1]) } @args); diff --git a/src/RxOp.pm b/src/RxOp.pm index c7aff330..14e17701 100644 --- a/src/RxOp.pm +++ b/src/RxOp.pm @@ -133,12 +133,12 @@ use CgOp; use Moose; extends 'RxOp'; - has thunk => (isa => 'Op', is => 'ro', required => 1); - sub opzyg { $_[0]->thunk } + has ops => (isa => 'Op', is => 'ro', required => 1); + sub opzyg { $_[0]->ops } sub code { my ($self, $body) = @_; - CgOp::rxbprim('Exact', CgOp::unbox('str', CgOp::fetch(CgOp::methodcall(CgOp::subcall(CgOp::fetch($self->thunk->cgop($body)), CgOp::newscalar(CgOp::rxcall('MakeCursor'))), "Str")))); + CgOp::rxbprim('Exact', CgOp::unbox('str', CgOp::fetch(CgOp::methodcall($self->ops->cgop($body), "Str")))); } sub lad { ['Imp'] } @@ -553,10 +553,9 @@ use CgOp; has passcap => (isa => 'Bool', is => 'ro', default => 0); has _passcapzyg => (isa => 'Maybe[RxOp]', is => 'rw'); has _passcapltm => (is => 'rw'); - has arglist => (isa => 'Maybe[ArrayRef[Op]]', is => 'ro'); has selfcut => (isa => 'Bool', is => 'ro', default => 0); - sub opzyg { ($_[0]->regex ? ($_[0]->regex) : ()), @{ $_[0]->arglist // [] } } + sub opzyg { ($_[0]->regex ? ($_[0]->regex) : ()) } sub used_caps { my ($self) = @_; @@ -582,13 +581,10 @@ use CgOp; my $bt = $self->label; my $sk = $self->label; - my @args = Op::CallLike::parsearglist($body, @{ $self->arglist // [] }); - my $callf = $self->regex ? - CgOp::subcall(CgOp::fetch($self->regex->cgop($body)), - CgOp::newscalar(CgOp::rxcall("MakeCursor")), @args) : + $self->regex->cgop($body) : CgOp::methodcall(CgOp::newscalar( - CgOp::rxcall("MakeCursor")), $self->method, @args); + CgOp::rxcall("MakeCursor")), $self->method); my @pushcapf = (@{ $self->captures } == 0) ? () : ($self->passcap ? (CgOp::rxsetcapsfrom(CgOp::cast("cursor", CgOp::letvar("k"))), @@ -710,7 +706,7 @@ use CgOp; sub code { my ($self, $body) = @_; CgOp::rxsetclass(CgOp::obj_llhow(CgOp::fetch( - CgOp::subcall(CgOp::fetch($self->expr->cgop($body)), CgOp::newscalar(CgOp::rxcall('MakeCursor')))))); + $self->expr->cgop($body)))); } sub lad { @@ -797,8 +793,7 @@ use CgOp; sub code { my ($self, $body) = @_; CgOp::ncgoto('backtrack', CgOp::unbox('bool', CgOp::fetch( - CgOp::methodcall(CgOp::subcall(CgOp::fetch($self->block->cgop($body)), - CgOp::newscalar(CgOp::rxcall("MakeCursor"))), "Bool")))); + CgOp::methodcall($self->block->cgop($body), "Bool")))); } sub lad { @@ -826,9 +821,7 @@ use CgOp; sub code { my ($self, $body) = @_; - CgOp::rxpushcapture(CgOp::subcall( - CgOp::fetch($self->block->cgop($body)), - CgOp::newscalar(CgOp::rxcall("MakeCursor"))), $self->capid); + CgOp::rxpushcapture($self->block->cgop($body), $self->capid); } sub lad { @@ -850,8 +843,7 @@ use CgOp; sub code { my ($self, $body) = @_; - CgOp::sink(CgOp::subcall(CgOp::fetch($self->block->cgop($body)), - CgOp::newscalar(CgOp::rxcall("MakeCursor")))); + CgOp::sink($self->block->cgop($body)); } sub lad {