<commit_before>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;
    
    # 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;
        
        # 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;
    }

    method can_chain_junction_be_warped($node) {
        sub has_core-ish_junction($node) {
            # TODO: add &infix:<^> to the list
            if nqp::istype($node, QAST::Op) && $node.op eq 'call' &&
                    (my $nodename := $node.name) eq '&infix:<|>' || $nodename eq '&infix:<&>' {
                if self.is_from_core($nodename) {
                    return 1;
                }
                return 0;
            }
            return 0;
        }
        my @warpable := [has_core-ish_junction($node[0]), has_core-ish_junction($node[1])];
        return @warpable;
    }
    
    # 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');
        }

        # we may be able to unfold a junction at compile time.
        if $op.op eq "if" || $op.op eq "unless" &&
           nqp::istype($op[0], QAST::Op) && $op[0].op eq "chain" {
            my @warpable := self.can_chain_junction_be_warped($op[0]);
            my $exp-side := -1;
            if @warpable[0] {
                $exp-side := 0;
            } elsif @warpable[1] {
                $exp-side := 1;
            }
            if $exp-side != -1 && $*LEVEL >= 3 {
                my $juncop := $op[0][$exp-side].name eq '&infix:<|>' ?? 'if' !! 'unless';
                my $juncname := $op[0][$exp-side].name eq '&infix:<&>' ?? '&infix:<&&>' !! '&infix:<||>';
                my $chainop := $op[0].op;
                my $chainname := $op[0].name;
                my $values := $op[0][$exp-side];
                my $ovalue := $op[0][1 - $exp-side];
                my %reference;
                sub refer_to($valop) {
                    my $id := $valop;
                    if nqp::existskey(%reference, $id) {
                        return QAST::Var.new(:name(%reference{$id}), :scope<local>);
                    }
                    %reference{$id} := $op.unique('junction_unfold');
                    return QAST::Op.new(:op<bind>,
                                        QAST::Var.new(:name(%reference{$id}),
                                                      :scope<local>,
                                                      :decl<var>),
                                        $valop);
                }
                sub chain($value) {
                    if $exp-side == 0 {
                        return QAST::Op.new(:op($chainop), :name($chainname),
                                            $value,
                                            refer_to($ovalue));
                    } else {
                        return QAST::Op.new(:op($chainop), :name($chainname),
                                            refer_to($ovalue),
                                            $value);
                    }
                }
                sub create_junc() {
                    my $junc := QAST::Op.new(:name($juncname), :op<chain>);
                    $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);<commit_msg>fixed junction ops, fixed is_from_core, added %!foldable_junction<commit_after>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;

    # 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{"&any"} := "&infix:<||>";
        %!foldable_junction{"&infix:<|>"} :=  "&infix:<||>";
        #%!foldable_junction{"&all"} :=  "&infix:<&&>";
        %!foldable_junction{"&infix:<&>"} :=  "&infix:<&&>";
        # TODO: none -> like |, but turn then and else branches around.
        #       or add prefix:<!> around
        # 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;
        }
        my @warpable := [has_core-ish_junction($node[0]), has_core-ish_junction($node[1])];
        return @warpable;
    }
    
    # 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');
        }

        # we may be able to unfold a junction at compile time.
        if $op.op eq "if" || $op.op eq "unless" &&
           nqp::istype($op[0], QAST::Op) && $op[0].op eq "chain" {
            my @warpable := self.can_chain_junction_be_warped($op[0]);
            my $exp-side := -1;
            if @warpable[0] {
                $exp-side := 0;
            } elsif @warpable[1] {
                $exp-side := 1;
            }
            if $exp-side != -1 && $*LEVEL >= 3 {
                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];
                my %reference;

                sub refer_to($valop) {
                    my $id := $valop;
                    if nqp::existskey(%reference, $id) {
                        return QAST::Var.new(:name(%reference{$id}), :scope<local>);
                    }
                    %reference{$id} := $op.unique('junction_unfold');
                    return QAST::Op.new(:op<bind>,
                                        QAST::Var.new(:name(%reference{$id}),
                                                      :scope<local>,
                                                      :decl<var>),
                                        $valop);
                }
                sub chain($value) {
                    if $exp-side == 0 {
                        return QAST::Op.new(:op($chainop), :name($chainname),
                                            $value,
                                            refer_to($ovalue));
                    } else {
                        return QAST::Op.new(:op($chainop), :name($chainname),
                                            refer_to($ovalue),
                                            $value);
                    }
                }
                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);
{'fraction_non_alphanumeric': 0.13708112643557607, 'fraction_numerical': 0.005139231212963448, 'mean_word_length': 1.3680615919533092, 'pattern_counts': {'":': 0, '<': 38, '<?xml version=': 0, '>': 47, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 28, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3477785', 'n_tokens_mistral': 5759, 'n_tokens_neox': 5482, 'n_words': 1441}