summaryrefslogtreecommitdiff
path: root/tests/examplefiles/Optimizer.pm6
diff options
context:
space:
mode:
Diffstat (limited to 'tests/examplefiles/Optimizer.pm6')
-rw-r--r--tests/examplefiles/Optimizer.pm6702
1 files changed, 0 insertions, 702 deletions
diff --git a/tests/examplefiles/Optimizer.pm6 b/tests/examplefiles/Optimizer.pm6
deleted file mode 100644
index 63844b0f..00000000
--- a/tests/examplefiles/Optimizer.pm6
+++ /dev/null
@@ -1,702 +0,0 @@
-use NQPP6QRegex;
-use QAST;
-
-# This powers the optimization pass. It takes place after we've done all
-# of the stuff in the grammar and actions, which means CHECK time is over.
-# Thus we're allowed to assume that lexpads are immutable, declarations are
-# over and done with, multi candidate lists won't change and so forth.
-class Perl6::Optimizer {
- # Tracks the nested blocks we're in; it's the lexical chain, essentially.
- has @!block_stack;
-
- # How deep a chain we're in, for chaining operators.
- has $!chain_depth;
-
- # Unique ID for topic ($_) preservation registers.
- has $!pres_topic_counter;
-
- # Unique ID for inline args variables.
- has $!inline_arg_counter;
-
- # Things that should cause compilation to fail; keys are errors, value is
- # array of line numbers.
- has %!deadly;
-
- # Things that should be warned about; keys are warnings, value is an array
- # of line numbers.
- has %!worrying;
-
- # The type type, Mu.
- has $!Mu;
-
- has %!foldable_junction;
- has %!foldable_outer;
-
- # Entry point for the optimization process.
- method optimize($past, *%adverbs) {
- # Initialize.
- @!block_stack := [$past[0]];
- $!chain_depth := 0;
- $!pres_topic_counter := 0;
- $!inline_arg_counter := 0;
- %!deadly := nqp::hash();
- %!worrying := nqp::hash();
- my $*DYNAMICALLY_COMPILED := 0;
- %!foldable_junction{'&infix:<|>'} := '&infix:<||>';
- %!foldable_junction{'&infix:<&>'} := '&infix:<&&>';
-
- # until there's a good way to figure out flattening at compile time,
- # don't support these junctions
- #%!foldable_junction{'&any'} := '&infix:<||>';
- #%!foldable_junction{'&all'} := '&infix:<&&>';
-
- %!foldable_outer{'&prefix:<?>'} := 1;
- %!foldable_outer{'&prefix:<!>'} := 1;
- %!foldable_outer{'&prefix:<so>'} := 1;
- %!foldable_outer{'&prefix:<not>'} := 1;
-
- %!foldable_outer{'if'} := 1;
- %!foldable_outer{'unless'} := 1;
- %!foldable_outer{'while'} := 1;
- %!foldable_outer{'until'} := 1;
-
- # Work out optimization level.
- my $*LEVEL := nqp::existskey(%adverbs, 'optimize') ??
- +%adverbs<optimize> !! 2;
-
- # Locate UNIT and some other useful symbols.
- my $unit := $past<UNIT>;
- my $*GLOBALish := $past<GLOBALish>;
- my $*W := $past<W>;
- unless nqp::istype($unit, QAST::Block) {
- nqp::die("Optimizer could not find UNIT");
- }
- nqp::push(@!block_stack, $unit);
- $!Mu := self.find_lexical('Mu');
- nqp::pop(@!block_stack);
-
- # Walk and optimize the program.
- self.visit_block($unit);
-
- # Die if we failed check in any way; otherwise, print any warnings.
- if +%!deadly {
- my @fails;
- for %!deadly {
- my @parts := nqp::split("\n", $_.key);
- my $headline := @parts.shift();
- @fails.push("$headline (line" ~ (+$_.value == 1 ?? ' ' !! 's ') ~
- nqp::join(', ', $_.value) ~ ")" ~
- (+@parts ?? "\n" ~ nqp::join("\n", @parts) !! ""));
- }
- nqp::die("CHECK FAILED:\n" ~ nqp::join("\n", @fails))
- }
- if +%!worrying {
- pir::printerr__vs("WARNINGS:\n");
- my @fails;
- for %!worrying {
- pir::printerr__vs($_.key ~ " (line" ~ (+$_.value == 1 ?? ' ' !! 's ') ~
- nqp::join(', ', $_.value) ~ ")\n");
- }
- }
-
- $past
- }
-
- # Called when we encounter a block in the tree.
- method visit_block($block) {
- # Push block onto block stack.
- @!block_stack.push($block);
-
- # Visit children.
- if $block<DYNAMICALLY_COMPILED> {
- my $*DYNAMICALLY_COMPILED := 1;
- self.visit_children($block);
- }
- else {
- self.visit_children($block);
- }
-
- # Pop block from block stack.
- @!block_stack.pop();
-
- # If the block is immediate, we may be able to inline it.
- my $outer := @!block_stack[+@!block_stack - 1];
- if $block.blocktype eq 'immediate' && !$*DYNAMICALLY_COMPILED {
- # Scan symbols for any non-interesting ones.
- my @sigsyms;
- for $block.symtable() {
- my $name := $_.key;
- if $name ne '$_' && $name ne 'call_sig' && $name ne '$*DISPATCHER' {
- @sigsyms.push($name);
- }
- }
-
- # If we have no interesting ones, then we can inline the
- # statements.
- # XXX We can also check for lack of colliding symbols and
- # do something in that case. However, it's non-trivial as
- # the static lexpad entries will need twiddling with.
- if +@sigsyms == 0 {
- if $*LEVEL >= 3 {
- return self.inline_immediate_block($block, $outer);
- }
- }
- }
-
- $block
- }
- method is_from_core($name) {
- my $i := +@!block_stack;
- while $i > 0 {
- $i := $i - 1;
- my $block := @!block_stack[$i];
- my %sym := $block.symbol($name);
- if +%sym && nqp::existskey(%sym, 'value') {
- my %sym := $block.symbol("!CORE_MARKER");
- if +%sym {
- return 1;
- }
- return 0;
- }
- }
- return 0;
- }
-
- method can_chain_junction_be_warped($node) {
- sub has_core-ish_junction($node) {
- if nqp::istype($node, QAST::Op) && $node.op eq 'call' &&
- nqp::existskey(%!foldable_junction, $node.name) {
- if self.is_from_core($node.name) {
- # TODO: special handling for any()/all(), because they create
- # a Stmts with a infix:<,> in it.
- if +$node.list == 1 {
- return 0;
- }
- return 1;
- }
- }
- return 0;
- }
-
- if has_core-ish_junction($node[0]) {
- return 0;
- } elsif has_core-ish_junction($node[1]) {
- return 1;
- }
- return -1;
- }
-
- # Called when we encounter a QAST::Op in the tree. Produces either
- # the op itself or some replacement opcode to put in the tree.
- method visit_op($op) {
- # If it's a QAST::Op of type handle, needs some special attention.
- my $optype := $op.op;
- if $optype eq 'handle' {
- return self.visit_handle($op);
- }
-
- # A chain with exactly two children can become the op itself.
- if $optype eq 'chain' {
- $!chain_depth := $!chain_depth + 1;
- $optype := 'call' if $!chain_depth == 1 &&
- !(nqp::istype($op[0], QAST::Op) && $op[0].op eq 'chain') &&
- !(nqp::istype($op[1], QAST::Op) && $op[1].op eq 'chain');
- }
-
- # there's a list of foldable outers up in the constructor.
- sub is_outer_foldable() {
- if $op.op eq "call" {
- if nqp::existskey(%!foldable_outer, $op.name) && self.is_from_core($op.name) {
- return 1;
- }
- } elsif nqp::existskey(%!foldable_outer, $op.op) {
- return 1;
- }
- return 0;
- }
-
- # we may be able to unfold a junction at compile time.
- if $*LEVEL >= 2 && is_outer_foldable() && nqp::istype($op[0], QAST::Op) && $op[0].op eq "chain" {
- my $exp-side := self.can_chain_junction_be_warped($op[0]);
- if $exp-side != -1 {
- my $juncop := $op[0][$exp-side].name eq '&infix:<&>' ?? 'if' !! 'unless';
- my $juncname := %!foldable_junction{$op[0][$exp-side].name};
- my $chainop := $op[0].op;
- my $chainname := $op[0].name;
- my $values := $op[0][$exp-side];
- my $ovalue := $op[0][1 - $exp-side];
-
- # the first time $valop is refered to, create a bind op for a
- # local var, next time create a reference var op.
- my %reference;
- sub refer_to($valop) {
- my $id := $valop;
- if nqp::existskey(%reference, $id) {
- QAST::Var.new(:name(%reference{$id}), :scope<local>);
- } else {
- %reference{$id} := $op.unique('junction_unfold');
- QAST::Op.new(:op<bind>,
- QAST::Var.new(:name(%reference{$id}),
- :scope<local>,
- :decl<var>),
- $valop);
- }
- }
-
- # create a comparison operation for the inner comparisons
- sub chain($value) {
- if $exp-side == 0 {
- QAST::Op.new(:op($chainop), :name($chainname),
- $value,
- refer_to($ovalue));
- } else {
- QAST::Op.new(:op($chainop), :name($chainname),
- refer_to($ovalue),
- $value);
- }
- }
-
- # create a chain of outer logical junction operators with inner comparisons
- sub create_junc() {
- my $junc := QAST::Op.new(:name($juncname), :op($juncop));
-
- $junc.push(chain($values.shift()));
-
- if +$values.list > 1 {
- $junc.push(create_junc());
- } else {
- $junc.push(chain($values.shift()));
- }
- return $junc;
- }
-
- $op.shift;
- $op.unshift(create_junc());
- #say($op.dump);
- return self.visit_op($op);
- }
- }
-
- # Visit the children.
- self.visit_children($op);
-
- # Calls are especially interesting as we may wish to do some
- # kind of inlining.
- if $optype eq 'call' && $op.name ne '' {
- # See if we can find the thing we're going to call.
- my $obj;
- my $found;
- try {
- $obj := self.find_lexical($op.name);
- $found := 1;
- }
- if $found {
- # If it's an onlystar proto, we have a couple of options.
- # The first is that we may be able to work out what to
- # call at compile time. Failing that, we can at least inline
- # the proto.
- my $dispatcher;
- try { if $obj.is_dispatcher { $dispatcher := 1 } }
- if $dispatcher && $obj.onlystar {
- # Try to do compile-time multi-dispatch. Need to consider
- # both the proto and the multi candidates.
- my @ct_arg_info := self.analyze_args_for_ct_call($op);
- if +@ct_arg_info {
- my @types := @ct_arg_info[0];
- my @flags := @ct_arg_info[1];
- my $ct_result_proto := pir::perl6_trial_bind_ct__IPPP($obj.signature, @types, @flags);
- my @ct_result_multi := pir::perl6_multi_dispatch_ct__PPPP($obj, @types, @flags);
- if $ct_result_proto == 1 && @ct_result_multi[0] == 1 {
- my $chosen := @ct_result_multi[1];
- if $op.op eq 'chain' { $!chain_depth := $!chain_depth - 1 }
- if $*LEVEL >= 2 {
- return nqp::can($chosen, 'inline_info') && nqp::istype($chosen.inline_info, QAST::Node)
- ?? self.inline_call($op, $chosen)
- !! self.call_ct_chosen_multi($op, $obj, $chosen);
- }
- }
- elsif $ct_result_proto == -1 || @ct_result_multi[0] == -1 {
- self.report_innevitable_dispatch_failure($op, @types, @flags, $obj,
- :protoguilt($ct_result_proto == -1));
- }
- }
-
- # Otherwise, inline the proto.
- if $op.op eq 'chain' { $!chain_depth := $!chain_depth - 1 }
- if $*LEVEL >= 2 {
- return self.inline_proto($op, $obj);
- }
- }
- elsif !$dispatcher && nqp::can($obj, 'signature') {
- # If we know enough about the arguments, do a "trial bind".
- my @ct_arg_info := self.analyze_args_for_ct_call($op);
- if +@ct_arg_info {
- my @types := @ct_arg_info[0];
- my @flags := @ct_arg_info[1];
- my $ct_result := pir::perl6_trial_bind_ct__IPPP($obj.signature, @types, @flags);
- if $ct_result == 1 {
- if $op.op eq 'chain' { $!chain_depth := $!chain_depth - 1 }
- #say("# trial bind worked!");
- if $*LEVEL >= 2 {
- return nqp::can($obj, 'inline_info') && nqp::istype($obj.inline_info, QAST::Node)
- ?? self.inline_call($op, $obj)
- !! copy_returns($op, $obj);
- }
- }
- elsif $ct_result == -1 {
- self.report_innevitable_dispatch_failure($op, @types, @flags, $obj);
- }
- }
- }
- }
- else {
- # We really should find routines; failure to do so is a CHECK
- # time error. Check that it's not just compile-time unknown,
- # however (shows up in e.g. sub foo(&x) { x() }).
- unless self.is_lexical_declared($op.name) {
- self.add_deadly($op, "Undefined routine '" ~ $op.name ~ "' called");
- }
- }
- }
-
- # If it's a private method call, we can sometimes resolve it at
- # compile time. If so, we can reduce it to a sub call in some cases.
- elsif $*LEVEL >= 3 && $op.op eq 'callmethod' && $op.name eq 'dispatch:<!>' {
- if $op[1].has_compile_time_value && nqp::istype($op[1], QAST::Want) && $op[1][1] eq 'Ss' {
- my $name := $op[1][2].value; # get raw string name
- my $pkg := $op[2].returns; # actions always sets this
- my $meth := $pkg.HOW.find_private_method($pkg, $name);
- if $meth {
- try {
- $*W.get_ref($meth); # may fail, thus the try; verifies it's in SC
- my $call := QAST::WVal.new( :value($meth) );
- my $inv := $op.shift;
- $op.shift; $op.shift; # name, package (both pre-resolved now)
- $op.unshift($inv);
- $op.unshift($call);
- $op.op('call');
- $op.name(nqp::null());
- }
- }
- else {
- self.add_deadly($op, "Undefined private method '" ~ $name ~ "' called");
- }
- }
- }
-
- # If we end up here, just leave op as is.
- if $op.op eq 'chain' {
- $!chain_depth := $!chain_depth - 1;
- }
- $op
- }
-
- # Handles visiting a QAST::Op :op('handle').
- method visit_handle($op) {
- self.visit_children($op, :skip_selectors);
- $op
- }
-
- # Handles visiting a QAST::Want node.
- method visit_want($want) {
- # Just visit the children for now. We ignore the literal strings, so
- # it all works out.
- self.visit_children($want, :skip_selectors)
- }
-
- # Handles visit a variable node.
- method visit_var($var) {
- # Nothing to do yet.
- }
-
- # Checks arguments to see if we're going to be able to do compile
- # time analysis of the call.
- my @allo_map := ['', 'Ii', 'Nn', 'Ss'];
- my %allo_rev := nqp::hash('Ii', 1, 'Nn', 2, 'Ss', 3);
- method analyze_args_for_ct_call($op) {
- my @types;
- my @flags;
- my @allomorphs;
- my $num_prim := 0;
- my $num_allo := 0;
-
- # Initial analysis.
- for @($op) {
- # Can't cope with flattening or named.
- if $_.flat || $_.named ne '' {
- return [];
- }
-
- # See if we know the node's type; if so, check it.
- my $type := $_.returns();
- my $ok_type := 0;
- try $ok_type := nqp::istype($type, $!Mu);
- if $ok_type {
- my $prim := pir::repr_get_primitive_type_spec__IP($type);
- my $allo := $_.has_compile_time_value && nqp::istype($_, QAST::Want)
- ?? $_[1] !! '';
- @types.push($type);
- @flags.push($prim);
- @allomorphs.push($allo);
- $num_prim := $num_prim + 1 if $prim;
- $num_allo := $num_allo + 1 if $allo;
- }
- else {
- return [];
- }
- }
-
- # See if we have an allomorphic constant that may allow us to do
- # a native dispatch with it; takes at least one declaratively
- # native argument to make this happen.
- if @types == 2 && $num_prim == 1 && $num_allo == 1 {
- my $prim_flag := @flags[0] || @flags[1];
- my $allo_idx := @allomorphs[0] ?? 0 !! 1;
- if @allomorphs[$allo_idx] eq @allo_map[$prim_flag] {
- @flags[$allo_idx] := $prim_flag;
- }
- }
-
- # Alternatively, a single arg that is allomorphic will prefer
- # the literal too.
- if @types == 1 && $num_allo == 1 {
- @flags[0] := %allo_rev{@allomorphs[0]} // 0;
- }
-
- [@types, @flags]
- }
-
- method report_innevitable_dispatch_failure($op, @types, @flags, $obj, :$protoguilt) {
- my @arg_names;
- my $i := 0;
- while $i < +@types {
- @arg_names.push(
- @flags[$i] == 1 ?? 'int' !!
- @flags[$i] == 2 ?? 'num' !!
- @flags[$i] == 3 ?? 'str' !!
- @types[$i].HOW.name(@types[$i]));
- $i := $i + 1;
- }
- self.add_deadly($op,
- ($protoguilt ?? "Calling proto of '" !! "Calling '") ~
- $obj.name ~ "' will never work with " ~
- (+@arg_names == 0 ??
- "no arguments" !!
- "argument types (" ~ nqp::join(', ', @arg_names) ~ ")"),
- $obj.is_dispatcher && !$protoguilt ??
- multi_sig_list($obj) !!
- [" Expected: " ~ $obj.signature.perl]);
- }
-
- # Signature list for multis.
- sub multi_sig_list($dispatcher) {
- my @sigs := [" Expected any of:"];
- for $dispatcher.dispatchees {
- @sigs.push(" " ~ $_.signature.perl);
- }
- @sigs
- }
-
- # Visits all of a nodes children, and dispatches appropriately.
- method visit_children($node, :$skip_selectors) {
- my $i := 0;
- while $i < +@($node) {
- unless $skip_selectors && $i % 2 {
- my $visit := $node[$i];
- if nqp::istype($visit, QAST::Op) {
- $node[$i] := self.visit_op($visit)
- }
- elsif nqp::istype($visit, QAST::Want) {
- self.visit_want($visit);
- }
- elsif nqp::istype($visit, QAST::Var) {
- self.visit_var($visit);
- }
- elsif nqp::istype($visit, QAST::Block) {
- $node[$i] := self.visit_block($visit);
- }
- elsif nqp::istype($visit, QAST::Stmts) {
- self.visit_children($visit);
- }
- elsif nqp::istype($visit, QAST::Stmt) {
- self.visit_children($visit);
- }
- }
- $i := $i + 1;
- }
- }
-
- # Locates a lexical symbol and returns its compile time value. Dies if
- # it does not exist.
- method find_lexical($name) {
- my $i := +@!block_stack;
- while $i > 0 {
- $i := $i - 1;
- my $block := @!block_stack[$i];
- my %sym := $block.symbol($name);
- if +%sym {
- if nqp::existskey(%sym, 'value') {
- return %sym<value>;
- }
- else {
- nqp::die("Optimizer: No lexical compile time value for $name");
- }
- }
- }
- nqp::die("Optimizer: No lexical $name found");
- }
-
- # Checks if a given lexical is declared, though it needn't have a compile
- # time known value.
- method is_lexical_declared($name) {
- my $i := +@!block_stack;
- while $i > 0 {
- $i := $i - 1;
- my $block := @!block_stack[$i];
- my %sym := $block.symbol($name);
- if +%sym {
- return 1;
- }
- }
- 0
- }
-
- # Inlines an immediate block.
- method inline_immediate_block($block, $outer) {
- # Sanity check.
- return $block if +@($block) != 2;
-
- # Extract interesting parts of block.
- my $decls := $block.shift;
- my $stmts := $block.shift;
-
- # Turn block into an "optimized out" stub (deserialization
- # or fixup will still want it to be there).
- $block.blocktype('declaration');
- $block[0] := QAST::Op.new( :op('die_s'),
- QAST::SVal.new( :value('INTERNAL ERROR: Execution of block eliminated by optimizer') ) );
- $outer[0].push($block);
-
- # Copy over interesting stuff in declaration section.
- for @($decls) {
- if nqp::istype($_, QAST::Op) && ($_.op eq 'p6bindsig' ||
- $_.op eq 'bind' && $_[0].name eq 'call_sig') {
- # Don't copy this binder call or setup.
- }
- elsif nqp::istype($_, QAST::Var) && ($_.name eq '$/' || $_.name eq '$!' ||
- $_.name eq '$_' || $_.name eq '$*DISPATCHER') {
- # Don't copy this variable node.
- }
- else {
- $outer[0].push($_);
- }
- }
-
- # Hand back the statements, but be sure to preserve $_
- # around them.
- $!pres_topic_counter := $!pres_topic_counter + 1;
- $outer[0].push(QAST::Var.new( :scope('local'),
- :name("pres_topic_$!pres_topic_counter"), :decl('var') ));
- return QAST::Stmts.new(
- :resultchild(1),
- QAST::Op.new( :op('bind'),
- QAST::Var.new( :name("pres_topic_$!pres_topic_counter"), :scope('local') ),
- QAST::Var.new( :name('$_'), :scope('lexical') )
- ),
- $stmts,
- QAST::Op.new( :op('bind'),
- QAST::Var.new( :name('$_'), :scope('lexical') ),
- QAST::Var.new( :name("pres_topic_$!pres_topic_counter"), :scope('local') )
- )
- );
- }
-
- # Inlines a proto.
- method inline_proto($call, $proto) {
- $call.unshift(QAST::Op.new(
- :op('p6mdthunk'),
- QAST::Var.new( :name($call.name), :scope('lexical') )));
- $call.name(nqp::null());
- $call.op('call');
- $call
- }
-
- # Inlines a call to a sub.
- method inline_call($call, $code_obj) {
- # If the code object is marked soft, can't inline it.
- if nqp::can($code_obj, 'soft') && $code_obj.soft {
- return $call;
- }
-
- # Bind the arguments to temporaries.
- my $inlined := QAST::Stmts.new();
- my @subs;
- for $call.list {
- my $temp_name := '_inline_arg_' ~ ($!inline_arg_counter := $!inline_arg_counter + 1);
- my $temp_type := $_.returns;
- $inlined.push(QAST::Op.new(
- :op('bind'),
- QAST::Var.new( :name($temp_name), :scope('local'), :returns($temp_type), :decl('var') ),
- $_));
- nqp::push(@subs, QAST::Var.new( :name($temp_name), :scope('local'), :returns($temp_type) ));
- }
-
- # Now do the inlining.
- $inlined.push($code_obj.inline_info.substitute_inline_placeholders(@subs));
- if $call.named -> $name {
- $inlined.named($name);
- }
- $inlined.node($call.node);
-
- $inlined
- }
-
- # If we decide a dispatch at compile time, this emits the direct call.
- method call_ct_chosen_multi($call, $proto, $chosen) {
- my @cands := $proto.dispatchees();
- my $idx := 0;
- for @cands {
- if $_ =:= $chosen {
- $call.unshift(QAST::Op.new(
- :op('p6mdcandthunk'),
- QAST::Var.new( :name($call.name), :scope('lexical') ),
- QAST::IVal.new( :value($idx) )
- ));
- $call.name(nqp::null());
- $call.op('call');
- #say("# Compile-time resolved a call to " ~ $proto.name);
- last;
- }
- $idx := $idx + 1;
- }
- $call := copy_returns($call, $chosen);
- $call
- }
-
- # Adds an entry to the list of things that would cause a check fail.
- method add_deadly($past_node, $message, @extras?) {
- my $mnode := $past_node.node;
- my $line := HLL::Compiler.lineof($mnode.orig, $mnode.from);
- my $key := $message ~ (+@extras ?? "\n" ~ nqp::join("\n", @extras) !! "");
- unless %!deadly{$key} {
- %!deadly{$key} := [];
- }
- %!deadly{$key}.push($line);
- }
-
- my @prim_spec_ops := ['', 'p6box_i', 'p6box_n', 'p6box_s'];
- my @prim_spec_flags := ['', 'Ii', 'Nn', 'Ss'];
- sub copy_returns($to, $from) {
- if nqp::can($from, 'returns') {
- my $ret_type := $from.returns();
- if pir::repr_get_primitive_type_spec__IP($ret_type) -> $primspec {
- $to := QAST::Want.new(
- :named($to.named),
- QAST::Op.new( :op(@prim_spec_ops[$primspec]), $to ),
- @prim_spec_flags[$primspec], $to);
- }
- $to.returns($ret_type);
- }
- $to
- }
-}
View Lorry Controller Status