PreviousUpNext

15.4.216  src/lib/compiler/back/low/block-placement/check-machcode-block-placement-g.pkg

## check-machcode-block-placement-g.pkg

# Compiled by:
#     src/lib/compiler/back/low/lib/lowhalf.lib



# This generic implements code to check
# that a block placement is correct.

stipulate
    package fil =  file__premicrothread;                                                # file__premicrothread          is from   src/lib/std/src/posix/file--premicrothread.pkg
    package odg =  oop_digraph;                                                         # oop_digraph                   is from   src/lib/graph/oop-digraph.pkg
    package lem =  lowhalf_error_message;                                               # lowhalf_error_message         is from   src/lib/compiler/back/low/control/lowhalf-error-message.pkg
herein
    # This generic is invoked (only) in:
    #
    #     src/lib/compiler/back/low/main/main/backend-lowhalf-g.pkg
    #
    generic package   check_machcode_block_placement_g   (
        #             ===============================
        #
        package mcg: Machcode_Controlflow_Graph;                                        # Machcode_Controlflow_Graph    is from   src/lib/compiler/back/low/mcg/machcode-controlflow-graph.api

        package mu:  Machcode_Universals                                                # Machcode_Universals           is from   src/lib/compiler/back/low/code/machcode-universals.api
                     where
                         mcf == mcg::mcf;                                               # "mcf" == "machcode_form" (abstract machine code).
    )
    : (weak) api {
        #
        package mcg:  Machcode_Controlflow_Graph;                                       # Machcode_Controlflow_Graph    is from   src/lib/compiler/back/low/mcg/machcode-controlflow-graph.api
        #
        check_machcode_block_placement
            :
            ( mcg::Machcode_Controlflow_Graph,
              List(mcg::Node)                                                           # Blocks.
            )
            -> Void;
    }
    {
        # Export to client packages:
        #       
        package mcg = mcg;


        dump_strm =  lowhalf_control::debug_stream;


        fun block_to_string (id', mcg::BBLOCK { id, ... } )
            =
            cat ["<", int::to_string id', ":", int::to_string id, ">"];


        fun check_machcode_block_placement (mcg as odg::DIGRAPH graph, nodes)
            =
            {
                # A rw_vector that maps from block id
                # to position in the placement (starting
                # from 1).
                #
                # Nodes that have no placement have index -1.
                #
                order = {   vec = rw_vector::make_rw_vector (graph.capacity (), -1);

                            fun init ((id, _), i)
                                =
                                {   rw_vector::set (vec, id, i);
                                    i+1;
                                };

                            ignore (list::fold_forward init 1 nodes);

                            vec;
                        };

                fun adjacent_nodes (a, b)
                    =
                    rw_vector::get (order, a) + 1
                    ==
                    rw_vector::get (order, b);


                saw_errors = REF FALSE;


                # Report an error and dump the mcg 
                #
                fun report_error msg
                    =
                    {   fun say s
                            =
                            fil::write (*dump_strm, s);

                        if (not *saw_errors)
                            #
                            saw_errors := TRUE;
                            say "********** Bogus block placement **********\n";
                        fi;

                        say (cat ("** " ! msg));
                    };

                fun report_not_adjacent (src, dst)
                    =
                    {   fun b2s id
                            =
                            cat [
                                int::to_string id, "@", int::to_string (rw_vector::get (order, id))
                            ];

                        report_error [
                            "Blocks ", b2s src, " and ", b2s dst,
                            " are not adjacent\n"
                          ];
                    };


                # Return TRUE if the edge
                # must connect adjacent nodes:
                #
                fun adj_edge (mcg::EDGE_INFO { kind => mcg::FALLSTHRU,     ... } ) =>  TRUE;
                    adj_edge (mcg::EDGE_INFO { kind => mcg::BRANCH FALSE,  ... } ) =>  TRUE;
                    adj_edge _                                                     =>  FALSE;
                end;

                # Entry and exit nodes:
                #
                entry_node_id =  mcg::entry_node_id_of_graph  mcg;
                exit_node_id  =  mcg::exit_node_id_of_graph   mcg;

                # Get the jump targets from the
                # last instruction in a block 
                #
                fun get_jump_targets id
                    =
                    case (graph.node_info id)
                        #
                        mcg::BBLOCK { ops => REF (i ! _), ... }
                            =>
                            case (mu::instruction_kind i)
                                #
                                mu::k::JUMP =>  mu::branch_targets i;
                                _           =>  [];
                            esac;


                          _ =>   [];
                      esac;


                # Check that FALLSTHRU and BRANCH FALSE
                # edges connect adjacent nodes 
                #
                fun check_edge (src, dst, mcg::EDGE_INFO { kind, ... } )
                    =
                    case kind
                        #
                        (mcg::FALLSTHRU | mcg::BRANCH FALSE)
                            =>
                            if (not (adjacent_nodes (src, dst)))
                                #
                                report_not_adjacent (src, dst);
                            fi;

                        mcg::BRANCH TRUE
                            =>
                            case (get_jump_targets src)
                                #
                                [mu::FALLTHROUGH, mu::LABELLED _] => ();
                                [mu::LABELLED _, mu::FALLTHROUGH] => ();

                                _   =>
                                    report_error [
                                        "Block ", int::to_string src,
                                        " doesn't end in conditiona branch\n"
                                    ];
                            esac;

                        mcg::JUMP
                            =>
                            case (get_jump_targets src)
                                #
                                [mu::LABELLED _] => ();

                                _   =>
                                    report_error [
                                        "Block ", int::to_string src, " doesn't end in jump\n"
                                    ];
                            esac;

                        mcg::ENTRY
                            =>
                            if (src != entry_node_id)
                                #
                                report_error [
                                    "Block ", int::to_string src, " is not ENTRY\n"
                                ];
                            fi;

                        mcg::EXIT
                            =>
                            if (dst != exit_node_id)
                                #
                                report_error [
                                    "Block ", int::to_string dst, " is not EXIT\n"
                                ];
                            else
                                case (get_jump_targets  src)
                                    #
                                    [mu::ESCAPES] => ();

                                    _   =>
                                        report_error [
                                            "Block ", int::to_string src,
                                            "doesn't end in an escaping jump\n"
                                        ];
                                esac;
                           fi;

                        _ => ();
                    esac;                       # No checking for SWITCH or FLOWSTO 


                graph.forall_edges  check_edge;

                if *saw_errors
                    #
                    fun say s =   fil::write (*dump_strm, s);

                    pr_node =  mcg::dump_node (*dump_strm, mcg);

                    say "Block placement order:\n";

                    list::apply
                        (fn b =  say (cat ["  ", block_to_string b, "\n"]))
                        nodes;

                    fil::write (*dump_strm, "[ machcode-controlflow-graph ]\n");
                    list::apply  pr_node  nodes;
                    say "**********\n";
                    lem::error ("check_machcode_block_placement_g", "bogus placement");
                fi;
            };                                                                                          # fun check
    };                                                                                                  # generic package  check_machcode_block_placement_g
end;                                                                                                    # stipulate

## COPYRIGHT (c) 2002 Bell Labs, Lucent Technologies
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2013,
## released per terms of SMLNJ-COPYRIGHT.


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext