PreviousUpNext

15.4.441  src/lib/compiler/back/low/treecode/rtl-build-g.pkg

## rtl-build-g.pkg -- derived from   ~/src/sml/nj/smlnj-110.58/new/new/src/MLRISC/mltree/rtl-build.sml
#
# Build Treecode-based RTLs 

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

stipulate
    package lem =  lowhalf_error_message;                                       # lowhalf_error_message         is from   src/lib/compiler/back/low/control/lowhalf-error-message.pkg
    package tcp =  treecode_pith;                                               # treecode_pith         is from   src/lib/compiler/back/low/treecode/treecode-pith.pkg
herein
    # This generic is invoked (only) in:
    #
    #     src/lib/compiler/back/low/tools/arch/adl-rtl.pkg
    #
    generic package   rtl_build_g   (
        #             ===========
        #
        rtl:  Treecode_Rtl
    )
    : (weak)  Rtl_Build                                                         # Rtl_Build                     is from   src/lib/compiler/back/low/treecode/rtl-build.api
    {
    #    package rtl =  rtl;

        package tcf =  rtl::tcf;

        stipulate
            package mi  =  tcf::mi;                                             # "mi" == "machine_int"
        herein

            Effect               = rtl::Rtl;
            Expression           = tcf::Int_Expression;
            Type            = tcf::Int_Bitsize;
            Flag_Expression = tcf::Flag_Expression;                             # flag expressions handle zero/parity/overflow/... flag stuff.
            Region               = tcf::Int_Expression;
            Cond                 = tcf::Cond;                                   # 
            Fcond                = tcf::Fcond;

            Div_Rounding_Mode = tcf::d::Div_Rounding_Mode;                      # Special rounding mode just for divide instructions.

            fun error msg
                =
                lem::error("rtl_build_g", msg);

            hash_counter = REF 0u23;

            fun new_hash ()
                =
                *hash_counter
                before
                    hash_counter := *hash_counter + 0u23499;

            fun new_oper name
                =
                { name,
                  hash       =>  new_hash (),
                  attributes =>  REF 0u0
                };

            new_op_list = REF [] :   Ref( List( tcp::Misc_Op ) );

            fun get_new_ops   () =   *new_op_list;
            fun clear_new_ops () =    new_op_list := [];

            fun new_op  name
                = 
                {   op =   new_oper name;

                    new_op_list := op ! *new_op_list;

                    op =   tcf::OPERATOR  op;

                    fn es =  tcf::OP (32, op, es);              #  XXX 
                };

            fun (:=) type (lhs, rhs)
                =
                tcf::ASSIGN (type, lhs, rhs);

            fun @@@ (k, type) e                                 # This fn was called $ in SML/NJ (i.e., MLRISC).
                =
                tcf::ATATAT (type, k, e);

            fun mem (k, type) (address, mem)
                =
                tcf::ATATAT (type, k, address);

            fun ??? type                                        # This really was called ??? in SML/NJ (i.e., MLRISC).
                =
                tcf::QQQ;

            fun arg (type, kind, name)
                =
                tcf::ARG (type, REF (tcf::REPX kind), name);

            fun bit_slice type slice e
                =
                tcf::BITSLICE (type, slice, e);

            fun operand type expression =   expression;
            fun immed   type expression =   expression;
            fun label   type expression =   expression;

            #  integer 

            fun int_const  type i =   tcf::LITERAL (mi::from_int   (type, i));
            fun unt_const  type u =   tcf::LITERAL (mi::from_unt1 (type, u));

            fun ternary_op op type (z, x, y) =   op (z, type, x, y);
            fun bin_op     op type (   x, y) =   op (   type, x, y);
            fun unary_op   op type (   x   ) =   op (   type, x   );

            fun sx (from, to) e =   tcf::SIGN_EXTEND (to, from, e);
            fun zx (from, to) e =   tcf::ZERO_EXTEND (to, from, e);

            (-_) = unary_op   tcf::NEG;
            +    = bin_op     tcf::ADD;
            -    = bin_op     tcf::SUB;
            muls = bin_op     tcf::MULS;
            divs = ternary_op tcf::DIVS;
            rems = ternary_op tcf::REMS;
            mulu = bin_op     tcf::MULU;
            divu = bin_op     tcf::DIVU;
            remu = bin_op     tcf::REMU;

            negt = unary_op   tcf::NEG_OR_TRAP;
            addt = bin_op     tcf::ADD_OR_TRAP;
            subt = bin_op     tcf::SUB_OR_TRAP;
            mult = bin_op     tcf::MULS_OR_TRAP;
            divt = ternary_op tcf::DIVS_OR_TRAP;

            bitwise_not    = unary_op tcf::BITWISE_NOT;
            bitwise_and    = bin_op   tcf::BITWISE_AND;
            bitwise_or     = bin_op   tcf::BITWISE_OR;
            bitwise_xor    = bin_op   tcf::BITWISE_XOR;

            eqvb           = bin_op   tcf::BITWISE_EQV;

            >>>            = bin_op   tcf::RIGHT_SHIFT;
            >>             = bin_op   tcf::RIGHT_SHIFT_U;
            <<             = bin_op   tcf::LEFT_SHIFT;

            true    = tcf::TRUE;
            false   = tcf::FALSE;
            not'    = tcf::NOT;
            and'    = tcf::AND;
            or'     = tcf::OR;
            xor'    = tcf::XOR;                                         # Oddly, this is not exported by   src/lib/compiler/back/low/treecode/rtl-build.api

            fun cmp cc type (x, y)     =   tcf::CMP              (type, cc,   x, y);
            fun cond type (cond, x, y) =   tcf::CONDITIONAL_LOAD (type, cond, x, y);

            ====  = cmp tcf::EQ;
            <>    = cmp tcf::NE;
            >=    = cmp tcf::GE;
            >     = cmp tcf::GT;
            <=    = cmp tcf::LE;
            <     = cmp tcf::LT;
            geu   = cmp tcf::GEU;
            gtu   = cmp tcf::GTU;
            leu   = cmp tcf::LEU;
            ltu   = cmp tcf::LTU;
            setcc = cmp tcf::SETCC;

            fun getcc type (e, cc)
                =
                tcf::CMP (type, cc, e, tcf::QQQ);

            #  floating point 

            fun i2f (type, x) =   tcf::INT_TO_FLOAT (type, type, x);
            fun f2i (type, x) =   tcf::FLOAT_TO_INT (type, tcf::ROUND_TO_ZERO, type, x);

            fun fbin_op   op type (x, y) =   f2i (type, op (type, i2f (type, x), i2f (type, y)));
            fun funary_op op type (x)    =   f2i (type, op (type, i2f (type, x)));

            fun fcmp fcc type (x, y)  =   tcf::FCMP (type, fcc, i2f (type, x), i2f (type, y));
            fun getfcc   type (e, cc) =   tcf::FCMP (type, cc,  i2f (type, e), i2f (type, tcf::QQQ));

            fadd      = fbin_op    tcf::FADD;
            fsub      = fbin_op    tcf::FSUB;
            fmul      = fbin_op    tcf::FMUL;
            fdiv      = fbin_op    tcf::FDIV;
            fcopysign = fbin_op    tcf::COPY_FLOAT_SIGN;
            #
            fneg      = funary_op  tcf::FNEG;
            fabs      = funary_op  tcf::FABS;
            fsqrt     = funary_op  tcf::FSQRT;

            # See comments and table in
            #
            #     src/lib/compiler/back/low/treecode/treecode-pith.api
            #
            |?|       = fcmp   tcf::FUO;
            |====|    = fcmp   tcf::FEQ;
            |?=|      = fcmp   tcf::FEQU;
            |<|       = fcmp   tcf::FLT;
            |?<|      = fcmp   tcf::FLTU;
            |<=|      = fcmp   tcf::FLE;
            |?<=|     = fcmp   tcf::FLEU;
            |>|       = fcmp   tcf::FGT;
            |?>|      = fcmp   tcf::FGTU;
            |>=|      = fcmp   tcf::FGE;
            |?>=|     = fcmp   tcf::FGEU;
            |<>|      = fcmp   tcf::FNE;
            |<=>|     = fcmp   tcf::FGLE;
            |?<>|     = fcmp   tcf::FNEU;
            setfcc    = fcmp   tcf::SETFCC;

            # Effects:
            #   
            nop' = tcf::SEQ [];

            fun jmp' type address
                =
                tcf::GOTO (address, []);

            fun call' type address
                =
                tcf::CALL
                  {
                    funct   =>  address,
                    targets =>  [],
                    defs    =>  [],
                    uses    =>  [], 
                    region  =>  tcf::rgn::memory,
                    pops    =>  0
                  };

            ret' =   tcf::RET  [];

            fun if' (tcf::TRUE,  yes, no) =>  yes;
                if' (tcf::FALSE, yes, no) =>  no;
                #
                if' (tcf::CMP (type, cc, x, y), tcf::SEQ [], no)
                        =>
                        tcf::IF (tcf::CMP (type, tcp::negate_cond cc, x, y), no, nop');
                #
                if' (a, b, c)
                    =>
                    tcf::IF (a, b, c);
            end;

            fun par' (tcf::SEQ [], y)           =>  y;
                par' (x, tcf::SEQ [])           =>  x;
                par' (tcf::SEQ xs, tcf::SEQ ys) =>  tcf::SEQ (xs @ ys);
                #
                par' (tcf::SEQ xs, y)           =>  tcf::SEQ (xs @ [y]);
                par' (x, tcf::SEQ ys)           =>  tcf::SEQ (x ! ys);
                par' (x, y)                             =>  tcf::SEQ [x, y];
            end; 

            map =   fn _ = list::map;
        end;                                                                            # stipulate
    };                                                                                  # generic package   rtl_build_g
end;                                                                                    # stipulate


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext