15.4.497  src/lib/compiler/back/top/improve/optutils.pkg

## optutils.pkg
## monnier@cs.yale.edu 

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

stipulate
    package acf =  anormcode_form;                              # anormcode_form                        is from   src/lib/compiler/back/top/anormcode/anormcode-form.pkg
    package hct =  highcode_type;                               # highcode_type                         is from   src/lib/compiler/back/top/highcode/highcode-type.pkg
    package hut =  highcode_uniq_types;                         # highcode_uniq_types                   is from   src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg
herein

    api Opt_Utils {

        Either (X,Y) = AA  X | BB  Y;

        # Takes the fk of a function and returns
        # the fk of the wrapper along with the
        # new fk of the actual body:
        #
        fk_wrap:  (acf::Function_Notes,
                   Null_Or( List( hut::Uniqtypoid ) ))
                  ->
                   (acf::Function_Notes, acf::Function_Notes);

        # This is a known APL function, but I don't know its real name:
        # 
        filter:  List( Bool ) -> List(X) -> List(X);

        # A less brain-dead version of
        # paired_lists::all: returns FALSE
        # if length l1 != length l2 *)
        #
        paired_lists_all:  ((X, Y) -> Bool) -> (List(X), List(Y)) -> Bool;

        pow2:  Int -> Int;

        # This is not a proper transposition in that
        # the order is reversed in the following way:
        #  transpose x = map reverse (proper_trans x)
        #
        exception UNBALANCED;
        transpose:  List( List(X) ) -> List( List(X) );

        foldl3:  ((X, Y, Z, W) -> W) -> W -> (List(X), List(Y), List(Z)) -> W;
    };
end;


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

    package opt_utils
    :       Opt_Utils           # Opt_Utils     is from   src/lib/compiler/back/top/improve/optutils.pkg
    {

        Either (X,Y) = AA X | BB Y;

        fun bug msg = error_message::impossible ("opt_utils: " + msg);

        fun fk_wrap ( { inlining_hint, private, loop_info, call_as }, rtys')
            =
            {   call_as'
                    =
                    case call_as
                        #
                        acf::CALL_AS_FUNCTION (hut::VARIABLE_CALLING_CONVENTION { arg_is_raw => f1,   body_is_raw => f2 }) =>
                        acf::CALL_AS_FUNCTION (hut::VARIABLE_CALLING_CONVENTION { arg_is_raw => TRUE, body_is_raw => f2 });

                        ( acf::CALL_AS_GENERIC_PACKAGE
                        | acf::CALL_AS_FUNCTION  hut::FIXED_CALLING_CONVENTION
                        )
                            =>
                            call_as;
                    esac;

                loop_info' =  null_or::map  (\\ ltys =  (ltys, acf::OTHER_LOOP))  rtys';

                ( { loop_info,             private,       call_as,           inlining_hint=>acf::INLINE_WHENEVER_POSSIBLE },
                  { loop_info=>loop_info', private=>TRUE, call_as=>call_as', inlining_hint                                }
                );
            };

        fun filter [] [] => [];
            filter (TRUE ! fs) (x ! xs)  => x ! (filter fs xs);
            filter (FALSE ! fs) (x ! xs) => (filter fs xs);
            filter _ _ => bug "unmatched list length in filter";
        end;

        fun paired_lists_all prior
            =
            allp
            where
                fun allp (a ! r1, b ! r2) => prior (a, b) and allp (r1, r2);
                    allp ([],[]) => TRUE;
                    allp _ => FALSE;
                end;
            end;

        fun pow2 n
            =
            unt::to_int (unt::(<<) (unt::from_int 1, unt::from_int n));

        exception UNBALANCED;

        fun transpose []
                =>
                [];

            transpose (xs ! xss)
                =>
                tr xss (map  (\\ x = [x])  xs)
                where
                    fun tr [] accs
                            =>
                            accs;

                        tr (xs ! xss) accs
                            =>
                            tr xss (f xs accs)
                            where
                                fun f [] [] => [];
                                    f (x ! xs) (acc ! accs) => (x ! acc) ! (f xs accs);
                                    f _ _ => raise exception UNBALANCED;
                                end;
                            end;
                    end;
                end;
        end;

        fun foldl3 f
            =
            l
            where
                fun l s ([],[],[]) => s;
                    l s (x1 ! x1s, x2 ! x2s, x3 ! x3s) => l (f (x1, x2, x3, s)) (x1s, x2s, x3s);
                    l _ _ => raise exception UNBALANCED;
                end;
            end;

    };                                                  # package opt_utils
end;



## copyright 1998 YALE FLINT PROJECT 
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.