PreviousUpNext

15.4.468  src/lib/compiler/back/top/forms/anormcode-runtime-type.pkg

## anormcode-runtime-type.pkg                           # "rttype.sml" in SML/NJ
#
# Support code used only in
#
#     src/lib/compiler/back/top/forms/drop-types-from-anormcode-junk.pkg

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



# Runtime type support for the A-Normal Form
# compiler passes -- for context see the
# comments in
#
#     src/lib/compiler/back/top/anormcode/anormcode-form.api



###                 "Computers are useless.
###                  They can only give you answers."
###
###                              -- Pablo Picasso



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

    api Anormcode_Runtime_Type {
        #
        Tcode;
        #
        tcode_truevoid: Tcode;
        tcode_record:   Tcode;
        tcode_int1:     Tcode;
        tcode_pair:     Tcode;
        tcode_fpair:    Tcode;
        tcode_float64:  Tcode;
        tcode_real_n:   Int -> Tcode;
        #
        tovalue:        Tcode -> acf::Value;
    };
end;


stipulate
    package acf =  anormcode_form;                              # anormcode_form                        is from   src/lib/compiler/back/top/anormcode/anormcode-form.pkg
    package di  =  debruijn_index;                              # debruijn_index                        is from   src/lib/compiler/front/typer/basics/debruijn-index.pkg
    package hbo =  highcode_baseops;                            # highcode_baseops                      is from   src/lib/compiler/back/top/highcode/highcode-baseops.pkg
    package hbt =  highcode_basetypes;                          # highcode_basetypes                    is from   src/lib/compiler/back/top/highcode/highcode-basetypes.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
herein

    package anormcode_runtime_type /* :> Anormcode_Runtime_Type */ {            # XXX BUGGO FIXME why isn't this API used at present?
        #

        Tcode = Int;

        fun bug s
            =
            error_message::impossible ("runtime_type: " + s);

        fun say (string:  String)
            =
            global_controls::print::say  string;

        fun make_var _
            =
            tmp::issue_highcode_codetemp();

        ident =   fn le => le; end ;

        fkfun = { loop_info=>NULL, private=>FALSE, inlining_hint=>acf::INLINE_WHENEVER_POSSIBLE, call_as => acf::CALL_AS_FUNCTION  hcf::fixed_calling_convention };
        fkfct = { loop_info=>NULL, private=>FALSE, inlining_hint=>acf::INLINE_IF_SIZE_SAFE,      call_as => acf::CALL_AS_GENERIC_PACKAGE };

#       fun mkarw (ts1, ts2)
#            =
#            hcf::make_arrow_uniqtyp (hcf::fixed_calling_convention, ts1, ts2);

        lt_arw =   hcf::make_typ_uniqtype o hcf::make_arrow_uniqtyp;

        stipulate
            fun  wrap_type tc =   (NULL, hbo::WRAP,   lt_arw (hcf::fixed_calling_convention, [tc], [hcf::truevoid_uniqtyp]), []);
            fun unwrap_type tc =   (NULL, hbo::UNWRAP, lt_arw (hcf::fixed_calling_convention, [hcf::truevoid_uniqtyp], [tc]), []);
        herein
            fun fu_wrap   (tc, vs, v, e) =  acf::BASEOP ( wrap_type  tc, vs, v, e);
            fun fu_unwrap (tc, vs, v, e) =  acf::BASEOP (unwrap_type tc, vs, v, e);
        end;

        fu_rk_tuple
            =
            anormcode_junk::rk_tuple;

        fun wrap_x (t, u)
            = 
            {   v = make_var(); 
                fu_wrap (t, [u], v, acf::RET [acf::VAR v]); 
            };

        fun unwrap_x (t, u)
            = 
            {   v = make_var(); 
                fu_unwrap (t, [u], v, acf::RET [acf::VAR v]); 
            };

        ###############################################################################
        #                  UTILITY FUNCTIONS AND CONSTANTS
        ###############################################################################
        fun split (acf::RET [v])
                =>
                (v, ident);

            split x
                =>
                {   v = make_var();
                    (acf::VAR v, fn z = acf::LET([v], x, z));
                };
        end;

        fun select_g (i, e)
            = 
            {   my (v, header) = split e;
                x = make_var();
                header (acf::GET_FIELD (v, i, x, acf::RET [acf::VAR x]));
            };

        fun fn_g (vts, e)
            = 
            {   f = make_var();
                acf::MUTUALLY_RECURSIVE_FNS([(fkfun, f, vts, e)], acf::RET [acf::VAR f]);
            };

        fun select_v (i, u)
            = 
            {   x = make_var();
                acf::GET_FIELD (u, i, x, acf::RET [acf::VAR x]);
            };

        fun app_g (e1, e2)
            = 
            {   my (v1, h1) = split e1;
                my (v2, h2) = split e2;

                h1 (h2 (acf::APPLY (v1, [v2])));
            };

        fun record_g es
            = 
            f (es, [], ident)
            where
                fun f ([], vs, header)
                        => 
                        {   x = make_var();
                            header (acf::RECORD (fu_rk_tuple, reverse vs, x, acf::RET [acf::VAR x]));
                        };

                    f (e ! r, vs, header)
                        => 
                        {   my (v, h) = split e;
                            f (r, v ! vs, header o h);
                        };
                end;
            end;

        fun srecord_g es
            = 
            f (es, [], ident)
            where
                fun f ([], vs, header)
                        => 
                        {   x = make_var();
                            header (acf::RECORD (acf::RK_PACKAGE, reverse vs, x, acf::RET [acf::VAR x]));
                        };

                    f (e ! r, vs, header)
                        => 
                        {   (split e) ->   (v, h);
                            #
                            f (r, v ! vs, header o h);
                        };
                end;
            end;

        fun wrap_g (z, b, e)
            = 
            {   (split e) ->   (v, h);
                #
                h (wrap_x (z, v));
            };

        fun unwrap_g (z, b, e)
            = 
            {   (split e) ->   (v, h);
                #
                h (unwrap_x (z, v));
            };

        fun wrap_cast (z, b, e)
            = 
            {   (split e) ->   (v, h);
                #
                pt = hcf::make_arrow_uniqtype (hcf::fixed_calling_convention, [hcf::make_typ_uniqtype z], [hcf::truevoid_uniqtype]);
                pv = (NULL, hbo::CAST, pt,[]);
                #
                x =  make_var ();
                #
                h (acf::BASEOP (pv, [v], x, acf::RET [acf::VAR x]));
            };

        fun unwrap_cast (z, b, e)
            = 
            {   my (v, h) = split e;
                pt = hcf::make_arrow_uniqtype (hcf::fixed_calling_convention, [hcf::truevoid_uniqtype], [hcf::make_typ_uniqtype z]);
                pv = (NULL, hbo::CAST, pt,[]);
                x = make_var();
                h (acf::BASEOP (pv, [v], x, acf::RET [acf::VAR x]));
            };

        fun switch_g (e, s, ce, d)
            = 
            {   (split e) ->   (v, h);
                #
                h (acf::SWITCH (v, s, ce, d));
            };

        fun cond (u, e1, e2)
            =
            u (e1, e2);

        fun wrap_x (t, u)
            = 
            {   v = make_var(); 
                fu_wrap (t, [u], v, acf::RET [acf::VAR v]); 
            };

        fun unwrap_x (t, u)
            = 
            {   v = make_var(); 
                fu_unwrap (t, [u], v, acf::RET [acf::VAR v]); 
            };


        intty    = hcf::int_uniqtype;
        boolty   = /* hcf::bool_uniqtype */ hcf::truevoid_uniqtype;
        inteqty  = hcf::make_arrow_uniqtype (hcf::fixed_calling_convention, [intty, intty], [boolty]);
        intopty  = hcf::make_arrow_uniqtype (hcf::fixed_calling_convention, [intty, intty], [intty]);
        ieqprim  = (NULL, hbo::ieql, inteqty, []);
        iaddprim = (NULL, hbo::iadd, intopty, []);

        fun ieq_lexp (e1, e2)
            = 
            {   (split e1) ->   (v1, h1);
                (split e2) ->   (v2, h2);

                fn (te, fe) => h1 (h2 (acf::BRANCH (ieqprim, [v1, v2], te, fe))); end ;
            };

        fun iadd_lexp (e1, e2)
            = 
            {   (split e1) ->   (v1, h1);
                (split e2) ->   (v2, h2);

                x = make_var (); 

                h1 (h2 (acf::BASEOP (iaddprim, [v1, v2], x, acf::RET [acf::VAR x])));
            };


        tcode_truevoid = 0;
        tcode_record   = 1;
        tcode_int1    = 2;
        tcode_pair     = 3;
        tcode_fpair    = 4;
        tcode_float64  = 5;

        fun tcode_real_n n
            =
            n * 5;


        fun tovalue i
            =
            acf::INT i;

        tolexp =  fn tcode =  acf::RET [tovalue tcode];

        my tcode_truevoid: acf::Expression =  tolexp tcode_truevoid;
        my tcode_record:   acf::Expression =  tolexp tcode_record;
        my tcode_int1:    acf::Expression =  tolexp tcode_int1;
        my tcode_pair:     acf::Expression =  tolexp tcode_pair;
        my tcode_fpair:    acf::Expression =  tolexp tcode_fpair;
        my tcode_float64:  acf::Expression =  tolexp tcode_float64;

        my tcode_real_n:   Int -> acf::Expression
            =
            fn i = tolexp (tcode_real_n i);

        Outcome 
          = YES
          | NO
          | MAYBE  acf::Expression
          ;

        ##############################################################################
        #                           KIND DICTIONARIES
        ##############################################################################

        Kenv = List( ( List( tmp::Codetemp ),
                       List( hut::Uniqkind )
                   ) ); 

        init_ke = [];

        fun add_ke (kenv, vs, ks)
            =
            (vs, ks) ! kenv;

        fun vlook_ke (kenv, i, j)
            = 
            {   my (vs, _)
                    =
                    list::nth (kenv, i - 1) 
                    except
                        _ = bug "unexpected case1 in vlook_ke";

                list::nth (vs, j)
                except
                    _ = bug "unexpected case2 in vlook_ke";
            };

        fun klook_ke (kenv, i, j)
            = 
            {   my (_, ks)
                    =
                    list::nth (kenv, i - 1) 
                    except
                        _ = bug "unexpected case1 in klook_ke";

                list::nth (ks, j)
                except
                    _ = bug "unexpected case2 in klook_ke";
            };


        # my tk_abs_gen:  kenv * List( Variable ) * List( Highcode_Kind ) * Variable * fkind 
        #                 -> kenv * ((acf::Expression * acf::Expression) -> acf::Expression)
        #
        fun tk_abs_fn (kenv, vs, ks, f, fk)
            = 
            {   make_arg_type = case fk  { call_as => acf::CALL_AS_FUNCTION _,      ... } =>  hcf::make_tuple_uniqtype;
                                         { call_as => acf::CALL_AS_GENERIC_PACKAGE, ... } =>  hcf::make_package_uniqtype;
                                esac;

              argt =  make_arg_type  (map  hcf::uniqkind_to_uniqtype  ks);

              w = make_var();

              fun h([], i, base) => base;
                  h (v ! r, i, base) => h (r, i+1, acf::GET_FIELD (acf::VAR w, i, v, base));
              end;

              fun header (e1, e2)
                  =
                  acf::MUTUALLY_RECURSIVE_FNS([(fk, f, [(w, argt)], h (vs, 0, e1))], e2);

              (add_ke (kenv, vs, ks), header);
          };

        # my tk_abs: (Kenv, List(( tvar, Highcode_Kind ))) -> (Kenv, ((acf::Expression, acf::Expression) -> acf::Expression)) 
        #
        fun tk_abs (kenv, tvks, f)
            = 
            {   my (vs, ks) =  paired_lists::unzip  tvks;
                #
                tk_abs_fn (kenv, vs, ks, f, fkfct);       
            };

        # my tk_tfn: (Kenv, List( hct::Highcode_Kind )) -> (Kenv, (acf::Expression -> acf::Expression)) 
        #
        fun tk_tfn (kenv, ks)
            = 
            {   vs =   map (fn _ = make_var ())   ks;
                f = make_var();
                #
                my (nkenv, header) =  tk_abs_fn (kenv, vs, ks, f, fkfun);
                #
                (nkenv, fn e = header (e, acf::RET [acf::VAR f]));
            };


        #  rt_lexr lvars, hut::typ::BASETYPE to proper constants 
        #  my rt_lexp:  kenv -> Uniqtyp -> rtype 
        #
        fun rt_lexp                                             # "rt" is probably "runtime"
            (kenv:  Kenv)
            (tc:    hut::Uniqtyp)
            = 
            loop tc
            where
                fun loop (x:  hut::Uniqtyp) 
                    = 
                    case (hut::uniqtyp_to_typ x)
                        #
                        hut::typ::TYPEFUN (ks, tx)
                            => 
                            {   my (nenv, header) = tk_tfn (kenv, ks);
                                header (rt_lexp nenv tx);
                            };

                        hut::typ::APPLY_TYPEFUN (tx, ts)
                            =>
                            case (hut::uniqtyp_to_typ tx)
                                #
                                ( hut::typ::APPLY_TYPEFUN _
                                | hut::typ::ITH_IN_TYPESEQ  _
                                | hut::typ::DEBRUIJN_TYPEVAR   _
                                )
                                    =>
                                    app_g (loop tx, tcs_lexp (kenv, ts));

                                _ =>  tcode_truevoid;
                            esac;

                        hut::typ::TYPESEQ ts
                            =>
                            tcs_lexp (kenv, ts);

                        hut::typ::ITH_IN_TYPESEQ (tx, i)
                            =>
                            select_g (i, loop tx);

                        hut::typ::BASETYPE pt
                            => 
                            if   (pt == hbt::basetype_float64)  tcode_float64; 
                            elif (pt == hbt::basetype_int1)    tcode_int1;
                            else                                   tcode_truevoid;
                            fi;

                        hut::typ::DEBRUIJN_TYPEVAR (i, j)
                            =>
                            acf::RET [(acf::VAR (vlook_ke (kenv, i, j)))];

                        hut::typ::TUPLE (_, [t1, t2])
                            =>
                            case (is_float (kenv, t1), is_float (kenv, t2))
                                #
                                (YES, YES)
                                    =>
                                    tcode_fpair;

                                ((NO, _) | (_, NO))
                                    =>
                                    tcode_pair;

                                ((MAYBE e, YES) | (YES, MAYBE e))
                                    =>
                                    {   test =  ieq_lexp (e, tcode_float64);
                                        #
                                        cond (test, tcode_fpair, tcode_pair);
                                    };

                               (MAYBE e1, MAYBE e2)
                                   =>
                                   {   e = iadd_lexp (e1, e2);
                                       test = ieq_lexp (e, tcode_real_n 2);
                                       cond (test, tcode_fpair, tcode_pair);
                                   };
                            esac;

                        hut::typ::TUPLE (_, [])       =>  tcode_truevoid;
                        hut::typ::TUPLE (_, ts)       =>  tcode_record;
                        hut::typ::ARROW (_, tc1, tc2) =>  tcode_truevoid;

                        hut::typ::ABSTRACT             tx  =>  loop tx;
                        hut::typ::EXTENSIBLE_TOKEN (_, tx) =>  loop tx;           

                        hut::typ::RECURSIVE ((n, tx, ts), i)
                            => 
                            {   ntx = case ts 
                                          #
                                          [] => tx;

                                           _ => 
                                             case (hut::uniqtyp_to_typ tx)
                                                 #
                                                 hut::typ::TYPEFUN(_, x) =>  x;
                                                 #
                                                 _ => bug "unexpected MUTUALLY_RECURSIVE_FNS 333 in rtLexp-loop";
                                             esac;
                                      esac;

                                tk = case (hut::uniqtyp_to_typ ntx)
                                         #
                                         hut::typ::TYPEFUN (ks, _) =>   list::nth (ks, i);
                                         #
                                         _ =>  bug "unexpected MUTUALLY_RECURSIVE_FNS typs in rtLexp-loop";
                                     esac;

                                case (hut::uniqkind_to_kind tk)
                                    #
                                    hut::kind::KINDFUN (ks, _)
                                        => 
                                        {   (tk_tfn (kenv, ks)) ->   (_, header);
                                            #
                                            header (tcode_truevoid);
                                        };

                                     _ => tcode_truevoid;
                                esac;
                            };

                        hut::typ::NAMED_TYPEVAR v    =>  acf::RET [acf::VAR v];

                        hut::typ::SUM          _ =>  bug "unexpected hut::typ::SUM Uniqtyp in rtLexp-loop";
                        hut::typ::TYPE_CLOSURE      _ =>  bug "unexpected hut::typ::TYPE_CLOSURE Uniqtyp in rtLexp-loop";
                        hut::typ::FATE         _ =>  bug "unexpected hut::typ::FATE Uniqtyp in rtLexp-loop";
                        hut::typ::INDIRECT_TYPE_THUNK     _ =>  bug "unexpected hut::typ::INDIRECT_TYPE_THUNK Uniqtyp in rtLexp-loop";
                        _                      =>  bug "unexpected Uniqtyp in rtLexp-loop";
                    esac;
            end         #  fun rt_lexp 

        also
        fun tcs_lexp (kenv, ts)
            = 
            {   fun h tc =  rt_lexp kenv tc;
                #
                record_g (map h ts);
             }

        also
        fun ts_lexp (kenv, ts)
            = 
            {   fun h tc =  rt_lexp kenv tc;
                #
                srecord_g (map h ts);
            }

        also
        fun is_float (kenv, tc)
            = 
            loop tc
            where
                fun loop x
                    = 
                    case (hut::uniqtyp_to_typ x)
                        #
                        hut::typ::BASETYPE pt
                            =>
                            pt == hbt::basetype_float64
                                ??  YES
                                ::  NO;

                        hut::typ::TUPLE (_, ts)       => NO;
                        hut::typ::ARROW (_, tc1, tc2) => NO;
                        hut::typ::RECURSIVE(_, i)     => NO;

                        hut::typ::EXTENSIBLE_TOKEN(_, tx)
                            =>
                            loop tx;

                        hut::typ::APPLY_TYPEFUN (tx, _)
                            => 
                            case (hut::uniqtyp_to_typ tx)
                                #
                                (hut::typ::APPLY_TYPEFUN _ | hut::typ::ITH_IN_TYPESEQ _ | hut::typ::DEBRUIJN_TYPEVAR _)
                                    => 
                                    MAYBE (rt_lexp kenv x);

                                _   => NO;

                            esac;
                      #  | (hut::typ::ABSTRACT tx) => loop tx  

                        hut::typ::DEBRUIJN_TYPEVAR (i, j)
                            =>
                            {   k = klook_ke (kenv, i, j);

                                case (hut::uniqkind_to_kind k)
                                    #   
                                    hut::kind::BOXEDTYPE =>  NO;
                                    _                                =>  MAYBE (rt_lexp kenv x);
                                esac;
                            }; 

                        _ => MAYBE (rt_lexp kenv x);

                    esac;
            end;

        fun is_pair (kenv, tc)
            = 
            loop tc
            where
                fun loop x
                    = 
                    case (hut::uniqtyp_to_typ x)
                        #
                        hut::typ::TUPLE (_, [_, _]) => YES;

                        hut::typ::TUPLE _         => NO;
                        hut::typ::BASETYPE pt         => NO;
                        hut::typ::ARROW _         => NO;
                        hut::typ::RECURSIVE(_, i) => NO;

                        hut::typ::EXTENSIBLE_TOKEN(_, tx)
                            =>
                            loop tx;

                        hut::typ::APPLY_TYPEFUN (tx, _)
                            => 
                            case (hut::uniqtyp_to_typ tx)
                                #
                                ( hut::typ::APPLY_TYPEFUN _
                                | hut::typ::ITH_IN_TYPESEQ  _
                                | hut::typ::DEBRUIJN_TYPEVAR   _
                                | hut::typ::NAMED_TYPEVAR _
                                )
                                    =>
                                    MAYBE (rt_lexp kenv x);

                                 _  =>  NO;
                            esac;

                   #     | (hut::typ::ABSTRACT tx) =>  loop tx  

                        _ =>  MAYBE (rt_lexp kenv x);
                    esac;
            end;
    };                                                                          # package anormcode_runtime_type 
end;                                                                            # stipulate



Comments and suggestions to: bugs@mythryl.org

PreviousUpNext