PreviousUpNext

15.4.493  src/lib/compiler/back/top/improve/eliminate-array-bounds-checks-in-anormcode.pkg

## eliminate-array-bounds-checks-in-anormcode.pkg
#
# "ABCOPT" -- Array Bounds Check Optimization
#
# I can't find the original paper on this,
# but it is probably somewhere in the FLINT papers.
#
# A similar later one is:
#
#      ABCD: Eliminating Array Bounds Checks on Demand
#      Bodik Gupta Sarkar
#      http://cseweb.ucsd.edu/classes/sp00/cse231/ABCD.ps

# Compiled by:
#     src/lib/compiler/core.sublib



# This is one of the A-Normal Form compiler passes --
# for context see the comments in
#
#     src/lib/compiler/back/top/anormcode/anormcode-form.api
#



###             "The mind is not a vessel to be filled
###              but a fire to be kindled."
###
###                                 -- Plutarch



stipulate
    package acf =  anormcode_form;                      # anormcode_form                is from   src/lib/compiler/back/top/anormcode/anormcode-form.pkg
herein

    api Eliminate_Array_Bounds_Checks_In_Anormcode {
        #
        eliminate_array_bounds_checks_in_anormcode
            :
            acf::Function -> acf::Function;
    };
end;


stipulate
    package acf =  anormcode_form;                      # anormcode_form                is from   src/lib/compiler/back/top/anormcode/anormcode-form.pkg
    package asc =  anormcode_sequencer_controls;        # anormcode_sequencer_controls  is from   src/lib/compiler/back/top/main/anormcode-sequencer-controls.pkg
    package hbo =  highcode_baseops;                    # highcode_baseops              is from   src/lib/compiler/back/top/highcode/highcode-baseops.pkg
    package hcf =  highcode_form;                       # highcode_form                 is from   src/lib/compiler/back/top/highcode/highcode-form.pkg
    package hct =  highcode_type;                       # highcode_type                 is from   src/lib/compiler/back/top/highcode/highcode-type.pkg
    package tmp =  highcode_codetemp;                   # highcode_codetemp             is from   src/lib/compiler/back/top/highcode/highcode-codetemp.pkg
    package hut =  highcode_uniq_types;                 # highcode_uniq_types           is from   src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg
    package im  =  int_red_black_map;                   # int_red_black_map             is from   src/lib/src/int-red-black-map.pkg
    package is  =  int_red_black_set;                   # int_red_black_set             is from   src/lib/src/int-red-black-set.pkg
    package pp  =  prettyprint_anormcode;               # prettyprint_anormcode         is from   src/lib/compiler/back/top/anormcode/prettyprint-anormcode.pkg
herein

    package   eliminate_array_bounds_checks_in_anormcode
    :         Eliminate_Array_Bounds_Checks_In_Anormcode                # Eliminate_Array_Bounds_Checks_In_Anormcode                    is from   src/lib/compiler/back/top/improve/eliminate-array-bounds-checks-in-anormcode.pkg
    {
        fun bug msg
            =
            error_message::impossible ("ABCOpt: " + msg);

        lvname = *pp::lvar_string;

        p_debug = REF FALSE;

        say = control_print::say;

        fun say_abc s =  ();
            # (if *ASC::printABC then say s
            #  else ())

        fun debug s = ();
            # (if *asc::printABC and *pDebug then
            #    say s
            #  else ())

        fun print_vals NIL => say "\n";
            print_vals (x ! xs) => { pp::print_sval x; say ", "; print_vals xs;};
        end;

        # We're invoked (only) from:
        #
        #     src/lib/compiler/back/top/main/backend-tophalf-g.pkg
        #
        fun eliminate_array_bounds_checks_in_anormcode (pgm as (progkind, progname, progargs, progbody))
            =
            {   lt_len
                    =
                    hcf::make_typ_uniqtype (
                        hcf::make_arrow_uniqtyp (
                            hcf::fixed_calling_convention,
                            [hcf::truevoid_uniqtyp], 
                            [hcf::int_uniqtyp]
                        )
                    );

                fun cse lmap rmap lambda_expression
                    =
                    g lambda_expression
                    where

                        fun subst_variable x
                            =
                            case (im::get (rmap, x))
                                #
                                THE y
                                    =>
                                    {    say_abc ("replacing: " +
                                                   (lvname x)   +
                                                   " with "     +
                                                   (lvname y)   +
                                                   "\n"); 
                                         y;
                                    };

                                NULL => x;
                            esac;

                        fun subst_val (acf::VAR x) =>   (acf::VAR (subst_variable x));
                            subst_val x           =>   x;
                        end;

                        fun subst_vals vals
                            =
                            map  subst_val  vals;

                        fun g (acf::BASEOP (p as (d, hbo::VECTOR_LENGTH_IN_SLOTS, lambda_type, typs), 
                                         [acf::VAR array_variable], dest, body))
                                =>
                                case (im::get (lmap, array_variable))
                                    #
                                    THE x =>   cse lmap (im::set (rmap, dest, x)) body; 
                                    #
                                    NULL  => 
                                        (acf::BASEOP 
                                         (p, [acf::VAR array_variable], dest,
                                          cse (im::set (lmap, array_variable, dest))
                                              rmap body));
                                esac;

                            g (acf::RET x)
                                =>
                                acf::RET (subst_vals x);

                            g (acf::LET (vars, lambda_expression, body))
                                => 
                                acf::LET (vars, g lambda_expression, g body);

                            g (acf::MUTUALLY_RECURSIVE_FNS (fundecs, body))
                                =>
                                acf::MUTUALLY_RECURSIVE_FNS (map h fundecs, g body);

                            g (acf::APPLY (v, vs))
                                =>
                                acf::APPLY (subst_val v, subst_vals vs);

                            g (acf::TYPEFUN (tfundec as (tfkind, lv, tvtks, tfnbody), body))
                                => 
                                acf::TYPEFUN ((tfkind, lv, tvtks, g tfnbody), g body);

                            g (acf::APPLY_TYPEFUN (v, typs))
                                =>
                                acf::APPLY_TYPEFUN (subst_val v, typs);

                            g (acf::SWITCH (v, constructor_api, cel, lexp_opt))
                                =>
                                {   fun hh (c, e)
                                        =
                                        (c, g e);

                                    cel' = map hh cel;

                                    fun gg (THE x) =>  THE (g x);
                                        gg NULL    =>  NULL;
                                    end;

                                    acf::SWITCH (subst_val v, constructor_api, cel', gg lexp_opt);
                                };

                            g (acf::CONSTRUCTOR (dcon, typs, v, lv, body))
                                =>
                                acf::CONSTRUCTOR (dcon, typs, subst_val v, lv, g body);

                            g (acf::RECORD (rk, vals, lv, body))
                                =>
                                acf::RECORD (rk, subst_vals vals, lv, g body);

                            g (acf::GET_FIELD (v, field', lv, body))
                                =>
                                acf::GET_FIELD (subst_val v, field', lv, g body);

                            g (acf::RAISE (v, type))
                                =>
                                acf::RAISE (subst_val v, type);

                            g (acf::EXCEPT (body, v))
                                =>
                                acf::EXCEPT (g body, subst_val v);

                            g (acf::BRANCH (p, vals, body1, body2))
                                => 
                                acf::BRANCH (p, subst_vals vals, g body1, g body2);

                            g (acf::BASEOP (p, vals, lv, body))
                                =>
                                acf::BASEOP (p, subst_vals vals, lv, g body);
                        end 

                        also
                        fun h (fk, highcode_variable, lvty, body)
                            =
                            (fk, highcode_variable, lvty, g body);


                    end;

                fun len_op (src, mm, body)
                    =
                    {   say_abc ("hoisting: length of " + (lvname src) + "\n");

                        case (im::get (mm, src))
                            #
                            THE lambda_type
                                =>
                                acf::BASEOP((NULL, hbo::VECTOR_LENGTH_IN_SLOTS, lambda_type, []),
                                         [acf::VAR src],
                                         tmp::issue_highcode_codetemp (),
                                         body);

                            NULL =>  bug "strange bug!";
                        esac;
                    };

                agressive_hoist =  REF TRUE;

                map_union     =  im::union_with (fn (a, b) => a; end );
                map_intersect =  im::intersect_with (fn (a, b) => a; end );

                fun remove' (m, k)
                     =
                     {   my (m', _) = im::drop (m, k);
                         m';
                     };

                fun say_vars NIL       =>  ();
                    say_vars (x ! NIL) =>  say_abc (lvname x);

                    say_vars (x ! xs)
                        =>
                        {   say_abc (lvname x);
                            say_abc ", ";
                            say_vars xs;
                        };
                end;

                fun hoist (acf::RET x)
                        =>
                        (im::empty, (acf::RET x));

                    hoist (acf::LET (vars, lambda_expression, body))
                        =>
                        {
                            my (m1, lambda_expression') = hoist lambda_expression;
                            my (m2, body') = hoist body;

                            fun ft x = im::contains_key (m2, x);
                            hlist = list::filter ft vars;

                            fun h NIL mm b => (mm, b);
                                h (x ! xs) mm b => 
                                h xs (remove' (mm, x)) (len_op (x, mm, b));
                            end;

                            my (m2', body'') = h hlist m2 body';

                            (map_union (m1, m2'), acf::LET (vars, lambda_expression', body''));
                        };

                    hoist (acf::MUTUALLY_RECURSIVE_FNS (fundecs, body))
                        =>
                        {   fun hoist_fundec (fk, lv,
                                             lvtys:  List( (tmp::Codetemp, hut::Uniqtype) ), 
                                             body)
                                =
                                {   var_list =  map #1 lvtys;

                                    my (m, b) =  hoist body;

                                    fun ft x
                                        =
                                        im::contains_key (m, x);

                                    to_hoist =  list::filter  ft  var_list;

                                    fun h mm NIL b
                                            =>
                                            (mm, b);

                                        h mm (v ! vs) b
                                            => 
                                            h (remove' (mm, v)) vs (len_op (v, mm, b));
                                    end;

                                    my (m', body')
                                        =
                                        h m to_hoist b;


                                    /*
                                    sayABC ("List of extern vars in " + (lvname lv) + " (MUTUALLY_RECURSIVE_FNS): [");
                                    sayVars (is::vals_list set);
                                    sayABC ("]\n");
                                     */

                                    say_abc ("List of hoisted vars in " +
                                            (lvname lv) + " (MUTUALLY_RECURSIVE_FNS): [");

                                    say_vars (to_hoist);

                                    say_abc ("]\n");

                                    (m', (fk, lv, lvtys, body'));
                                };


                            #  fundec sets and bodys 
                            fsbody =  map hoist_fundec fundecs;
                            fsets  =  map #1 fsbody;
                            fbody  =  map #2 fsbody;

                            my (bmap, newbody)
                                =
                                hoist body;

                            mmm =  fold_forward map_union bmap fsets;


                            (mmm, acf::MUTUALLY_RECURSIVE_FNS (fbody, newbody));
                        };

                    hoist (acf::APPLY x)
                        =>
                        (im::empty, acf::APPLY x);

                    hoist (acf::TYPEFUN (tfundec as (tfkind, lv, tvtks, tfnbody), body))
                        =>
                        {   my (mtfn, btfn) =  hoist tfnbody;
                            my (m, b)       =  hoist body;

                            (map_union (mtfn, m), acf::TYPEFUN (tfundec, b));
                        };

                    hoist (acf::APPLY_TYPEFUN (v, tl))
                        =>
                        (im::empty, acf::APPLY_TYPEFUN (v, tl));


                    #  If agressive, use union; otherwise use intersect 
                    #  no var defined, so no hoisting 

                    hoist (acf::SWITCH (v, constructor_api, clexps, lambda_expression))
                        =>
                        {
                            lexps =  map #2 clexps;

                            sblist = (map hoist lexps);

                            maps  =  map #1 sblist;
                            bodys =  map #2 sblist;

                            my (def_map, def_body)
                                =
                                case lambda_expression

                                     THE l
                                         =>
                                         {   my (m, b) =   hoist l;

                                             (THE m, THE b);
                                         };

                                     NULL =>  (NULL, NULL);
                                esac;


                            #  Agressive may not always be beneficial 
                            #  it's turned off by default 

                            map_oper
                                =
                                if   *agressive_hoist      map_union;
                                else                       map_intersect;
                                fi;

                            result_set
                                =
                                fold_forward
                                    map_oper
                                    (head maps)
                                    (tail maps);


                            fun helper NIL nil
                                    =>
                                    NIL;

                                helper ((c, le) ! xs) (le' ! ys)
                                    =>
                                    (c, le') ! (helper xs ys);

                                helper _ _ => bug "no!!!! help!!!!\n";
                            end;

                            result_clexps = helper clexps bodys;


                            ( case def_map
                                  THE m => map_oper (m, result_set);
                                  NULL  => result_set;
                              esac,

                              acf::SWITCH (v, constructor_api, result_clexps, def_body)
                            );
                        };


                    # There probably isn't anything
                    # interesting here but: 
                    #
                    hoist (acf::CONSTRUCTOR (d, tl, v, lv, le))
                        =>
                        {   my (m, b) =  hoist le;

                            if    (im::contains_key (m, lv))

                                 (remove' (m, lv),
                                 acf::CONSTRUCTOR (d, tl, v, lv, len_op (lv, m, b)));
                            else
                                 (m, acf::CONSTRUCTOR (d, tl, v, lv, b));
                            fi;
                        };


                    # There probably isn't anything
                    # interesting here either:
                    #
                    hoist (acf::RECORD (rk, vals, lv, le))
                        =>
                        {   my (m, b) =   hoist le;

                            if   (im::contains_key (m, lv))

                                 (remove' (m, lv),
                                 acf::RECORD (rk, vals, lv, len_op (lv, m, b)));
                            else
                                 (m, acf::RECORD (rk, vals, lv, b));
                            fi;
                        };

                    hoist (acf::GET_FIELD (v, f, lv, le))
                        =>
                        {   (hoist le) ->   (m, b);
                            #
                            if (im::contains_key (m, lv))
                                #
                                (remove' (m, lv), 
                                #
                                acf::GET_FIELD (v, f, lv, len_op (lv, m, b)));
                            else
                                (m, acf::GET_FIELD (v, f, lv, b));
                            fi;
                        };

                    hoist (acf::RAISE (v, ltys))
                        => 
                        (im::empty, acf::RAISE (v, ltys));

                    hoist (acf::EXCEPT (le, v))
                        =>
                        {   my (m, b) =  hoist le;

                            (m, acf::EXCEPT (b, v));
                        };


                    # We just use the intersection
                    # of the two branches:
                    #
                    hoist (acf::BRANCH (po, vals, le1, le2))
                        =>
                        {   my (m1, b1) = hoist le1;
                            my (m2, b2) = hoist le2;

                            map_oper
                                =
                                *agressive_hoist
                                    ??  map_union
                                    ::  map_intersect;

                            /*
                            sayABC "for this branch: [";
                            sayVars (is::vals_list (is::union (s1, s2)));
                            sayABC "]\n";
                             */
                            (map_oper (m1, m2), acf::BRANCH (po, vals, b1, b2));
                        };



                    # The use site:
                    #
                    hoist (acf::BASEOP (p as (d, hbo::VECTOR_LENGTH_IN_SLOTS, lambda_type, typs),
                                    vals, dest, body))
                        =>
                        {   my (m, b) =   hoist body;

                            say_abc "got one!\n";

                            case vals
                                #
                                [acf::VAR x]
                                    =>
                                    (im::set (m, x, lambda_type), 
                                              acf::BASEOP (p, vals, dest, b));
                                _   =>
                                    (m, acf::BASEOP (p, vals, dest, b));
                            esac;
                        };


                    # The result of a baseop
                    # is unlikely to be an rw_vector but:
                    #   
                    hoist (acf::BASEOP (p, vals, dest, body))
                        =>
                        {   my (m, b) =   hoist body;

                            if (im::contains_key (m, dest))
                                #
                                (remove' (m, dest),
                                acf::BASEOP (p, vals, dest, len_op (dest, m, b)));
                            else
                                (m, acf::BASEOP (p, vals, dest, b));
                            fi;
                        };
                end;

                fun elim_switches
                        cmps_vv
                        cmps_iv
                        lambda_expression
                    =
                    g lambda_expression
                    where

                        compare_lambda_types
                            = 
                            hcf::make_typ_uniqtype 
                                (hcf::make_arrow_uniqtyp (hcf::fixed_calling_convention,
                                               [hcf::int_uniqtyp, hcf::int_uniqtyp],
                                               [hcf::truevoid_uniqtyp]));

                        fun g (acf::LET ([lv], 
                                      br as 
                                         (acf::BRANCH (p as (NULL, 
                                                          hbo::CMP { op=>hbo::LTU,  kindbits=>hbo::UNT 31 },
                                                          compare_lambda_types,
                                                          NIL),
                                                    [val1, val2],
                                                    tbr,
                                                    #  just to make sure it's an ABC 
                                                    fbr as
                                                        (acf::RECORD
                                                             (_, _, _,
                                                              acf::RECORD
                                                                  (_, _, _,
                                                                   acf::BASEOP
                                                                       ((_, hbo::WRAP, _, _), _, _,
                                                                        acf::BASEOP
                                                                            ((_, hbo::MARK_EXCEPTION_WITH_STRING, _, _), _, _,
                                                                             acf::RAISE _))))))),
                                         body))
                                => 
                                {
                                    fun decide (acf::VAR v1, acf::VAR v2)
                                            =>
                                            {
                                                fun lookup (v1, v2)
                                                    =
                                                    {   say_abc ("cmp: looking for " + (lvname v1)  + 
                                                             " and " + (lvname v2) + "\n");

                                                        case (im::get (cmps_vv, v2))

                                                             THE set => is::member (set, v1);
                                                             NULL => FALSE;
                                                        esac;
                                                    };

                                                fun add (v1, v2)
                                                    =
                                                    {   say_abc ("cmp: entering " + (lvname v1)  + 
                                                             " and " + (lvname v2) + "\n");

                                                         case (im::get (cmps_vv, v2))

                                                              THE set
                                                                  =>
                                                                  im::set (cmps_vv, v2, is::add (set, v1));

                                                              NULL
                                                                  =>
                                                                  im::set (cmps_vv, v2, is::singleton v1);
                                                         esac;
                                                     };

                                                if   (lookup (v1, v2))
                                                     (TRUE, cmps_vv, cmps_iv);
                                                else (FALSE, add (v1, v2), cmps_iv);
                                                fi;
                                            };

                                        decide (acf::INT n, acf::VAR v)
                                            =>
                                            {   fun lookup (n, v)
                                                    =
                                                    {   say_abc ("looking for ("  + 
                                                                (int::to_string n) + "<"  + 
                                                                (lvname v) + ")\n");

                                                        if   (n == 0)

                                                             TRUE;
                                                        else
                                                             case (im::get (cmps_iv, v))

                                                                  THE x =>  (n <= x);
                                                                  NULL  =>  FALSE;
                                                             esac;
                                                        fi;
                                                    };

                                                fun add (n, v)
                                                    =
                                                    im::set (cmps_iv, v, n);


                                                if  (lookup (n, v)  )  (TRUE,  cmps_vv, cmps_iv);
                                                                   else  (FALSE, cmps_vv, add (n, v));   fi;
                                            };

                                        decide _
                                            =>
                                            (FALSE, cmps_vv, cmps_iv);
                                    end;

                                    my (to_elim, new_vv, new_iv)
                                        =
                                        decide (val1, val2);


                                    if to_elim
                                        #
                                        case tbr
                                            #
                                             acf::BASEOP (p, vals, lv1, acf::RET [acf::VAR lv2])
                                                 =>
                                                 if (lv1 == lv2)   acf::BASEOP (p, vals, lv, g body);
                                                 else              acf::LET ([lv], g tbr, g body);
                                                 fi;

                                             _ => acf::LET ([lv], g tbr, g body);
                                        esac;
                                    else
                                        (acf::LET
                                          ( [lv],
                                            acf::BRANCH
                                              ( p, 
                                                [val1, val2],
                                                elim_switches new_vv new_iv tbr,
                                                g fbr
                                              ),
                                              elim_switches new_vv new_iv body
                                          )
                                        );
                                    fi;
                                };

                            g (acf::RET x)
                                =>
                                acf::RET x;

                            g (acf::LET (vars, lambda_expression, body))
                                =>
                                acf::LET (vars, g lambda_expression, g body);

                            g (acf::MUTUALLY_RECURSIVE_FNS (fundecs, body))
                                =>
                                acf::MUTUALLY_RECURSIVE_FNS (map h fundecs, g body);

                            g (acf::APPLY (v, vs))
                                =>
                                acf::APPLY (v, vs);

                            g (acf::TYPEFUN (tfundec, body))
                                =>
                                acf::TYPEFUN (tfundec, g body);

                            g (acf::APPLY_TYPEFUN (v, typs))
                                =>
                                acf::APPLY_TYPEFUN (v, typs);

                            g (acf::SWITCH (v, constructor_api, cel, lexpopt))
                                =>
                                {   fun hh (c, e) =   (c, g e);

                                    cel' =   map hh cel;

                                    fun gg (THE x) =>  THE (g x);
                                        gg NULL    =>  NULL;
                                    end;


                                    acf::SWITCH (v, constructor_api, cel', gg lexpopt);
                                };

                            g (acf::CONSTRUCTOR (dcon, typs, v, lv, body))
                                =>
                                acf::CONSTRUCTOR (dcon, typs, v, lv, g body);

                            g (acf::RECORD (rk, vals, lv, body))
                                =>
                                acf::RECORD (rk, vals, lv, g body);

                            g (acf::GET_FIELD (v, field', lv, body))
                                =>
                                acf::GET_FIELD (v, field', lv, g body);

                            g (acf::RAISE (v, type))
                                =>
                                acf::RAISE (v, type);

                            g (acf::EXCEPT (body, v))
                                =>
                                acf::EXCEPT (g body, v);

                            g (acf::BRANCH (p, vals, body1, body2))
                                =>
                                acf::BRANCH (p, vals, g body1, g body2);

                            g (acf::BASEOP (p, vals, lv, body))
                                =>
                                acf::BASEOP (p, vals, lv, g body);
                        end 

                        also
                        fun h (fk, highcode_variable, lvty, body)
                            =
                            (fk, highcode_variable, lvty, g body);


                    end;

                my (s, hoisted) =   hoist progbody;

                csed =   cse im::empty im::empty hoisted;

                elimed =   elim_switches im::empty im::empty csed;

                #               optimized = (progkind, progname, progargs, elimed)
                optimized = (progkind, progname, progargs, elimed);

                #  some advertising stuff! 

                # if *asc::printABC then
                #       (say "\nhello! This is ABCOpt!\n";
                # 
                #        (say "[Before ABCOpt...]\n\n";
                #         pp::printProg pgm);
                #        
                #        (say "\n[After Hoisting...]\n\n";
                #         pp::printProg (progkind, progname, progargs, hoisted));
                #        
                #        (say "\n[After CSE...]\n\n";
                #         pp::printProg (progkind, progname, progargs, csed));
                # 
                #        (say "\n[After Elim...]\n\n";
                #         pp::printProg (progkind, progname, progargs, elimed));
                # 
                #        say "\nbyebye! i'm done!\n\n")
                # fi;

                #  Can eventually be removed after testing 
                /*
                case (is::vals_list s)
                    #
                    NIL => ();
                    _   => bug "should be NIL!!!";
                esac;
                 */

                optimized;
            };
    };
end;



###             "You know what I like?  I like that brief idyllic
###              moment between the invention of the flush toilet
###              and nuclear armageddon, when civilization seems
###              sane and beneficent and eternal."




Comments and suggestions to: bugs@mythryl.org

PreviousUpNext