PreviousUpNext

15.4.506  src/lib/compiler/back/top/lambdacode/translate-lambdacode-to-anormcode.pkg

## translate-lambdacode-to-anormcode.pkg
## monnier@cs.yale.edu 
#
# Converting lambdacode_form::Lambdacode_Expression
# to         anormcode_form::Function.
#
#
#
# CONTEXT:
#
#     The Mythryl compiler code representations used are, in order:
#
#     1)  Raw Syntax is the initial frontend code representation.
#     2)  Deep Syntax is the second and final frontend code representation.
#     3)  Lambdacode is the first backend code representation, used only transitionally.
#     4)  Anormcode (A-Normal format) is the second backend code representation, and the first used for optimization.
#     5)  Nextcode is the third and chief backend tophalf code representation.
#     6)  Treecode is the backend tophalf/lowhalf transitional code representation. It is typically slightly specialized for each target architecture, e.g. Intel32 (x86).
#     7)  Machcode abstracts the target architecture machine instructions. It gets specialized for each target architecture.
#     8)  Execode is absolute executable binary machine instructions for the target architecture.
#
#     Our task here is converting from the third to the fourth form.
#
#
#
# For lambdacode code format see:            src/lib/compiler/back/top/lambdacode/lambdacode-form.api
# For A-Normal code format see:              src/lib/compiler/back/top/anormcode/anormcode-form.api
# We get invoked (only) from:                src/lib/compiler/toplevel/main/translate-raw-syntax-to-execode-g.pkg

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





###                      "Reading a translation is like examining
###                       the back of a piece of tapesty."
###
###                                              -- Cervantes.



#DO set_control "compiler::trap_int_overflow" "TRUE";

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

    api Translate_Lambdacode_To_Anormcode {
        #
        translate_lambdacode_to_anormcode
            :
            lcf::Lambdacode_Expression
            ->
            acf::Function;
    };
end;


stipulate
    package acf =  anormcode_form;                              # anormcode_form                        is from   src/lib/compiler/back/top/anormcode/anormcode-form.pkg
    package acj =  anormcode_junk;                              # anormcode_junk                        is from   src/lib/compiler/back/top/anormcode/anormcode-junk.pkg
    package di  =  debruijn_index;                              # debruijn_index                        is from   src/lib/compiler/front/typer/basics/debruijn-index.pkg
    package m2m =  convert_monoarg_to_multiarg_anormcode;       # convert_monoarg_to_multiarg_anormcode is from   src/lib/compiler/back/top/lambdacode/convert-monoarg-to-multiarg-anormcode.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 hut =  highcode_uniq_types;                         # highcode_uniq_types                   is from   src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg
    package lcf =  lambdacode_form;                             # lambdacode_form                       is from   src/lib/compiler/back/top/lambdacode/lambdacode-form.pkg
    package tt  =  type_types;                                  # type_types                            is from   src/lib/compiler/front/typer/types/type-types.pkg
    package ty  =  types;                                       # types                                 is from   src/lib/compiler/front/typer-stuff/types/types.pkg
herein


    package   translate_lambdacode_to_anormcode
    : (weak)  Translate_Lambdacode_To_Anormcode                 # Translate_Lambdacode_To_Anormcode     is from   src/lib/compiler/back/top/lambdacode/translate-lambdacode-to-anormcode.pkg
    {
        say   = control_print::say;

        make_var =  highcode_codetemp::issue_highcode_codetemp;

        ident = fn le:  lcf::Lambdacode_Expression
                    =
                    le;

        my (iadd_prim, uadd_prim)
            = 
            {   lt_int = hcf::int_uniqtype;

                int_op_type = hcf::make_lambdacode_arrow_uniqtype (hcf::make_tuple_uniqtype [lt_int, lt_int], lt_int);

                addu = hbo::MATH { op=>hbo::ADD, overflow=>FALSE, kindbits=>hbo::UNT 31 };
            
                ( lcf::BASEOP (hbo::iadd, int_op_type, []),
                  lcf::BASEOP (addu,      int_op_type, [])
                );
            };

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

        stipulate
            my (true_dcon', false_dcon')
                = 
                ( h tt::true_dcon,
                  h tt::false_dcon
                )
                where
                    type =  hcf::make_arrow_uniqtype                            # Highcode type "Void -> Bool".
                              (
                                hcf::rawraw_variable_calling_convention,
                                [ hcf::void_uniqtype ],
                                [ hcf::bool_uniqtype ]
                              );

                    fun h (ty::VALCON { name, form, ... } )
                        =
                        (name, form, type);
                end;

            fun bool_lexp b
                = 
                {   v = make_var();
                    w = make_var();

                    dc = if b  true_dcon'; else false_dcon';fi;
                
                    acf::RECORD (acj::rk_tuple, [], v, 
                    acf::CONSTRUCTOR (dc, [], acf::VAR v, w, acf::RET [acf::VAR w]));
                };
        herein 

            fun highcode_baseop
                  ( baseop                                                      # : acf::Baseop
                        as
                        ( dictionary:   Null_Or( acf::Dictionary ),             # Map from types to matching make_foo fns.
                          op:           hbo::Baseop,                            # Op to perform -- add, shift, fetch-from-vector, whatever.
                          op_type:      hut::Uniqtype,                          # Result of op.
                          arg_types:    List( hut::Uniqtyp )
                        ),
                    vs,                                                         # Arg vals
                    v,                                                          # Highcode var
                    e                                                           # c_lexp
                  )
                = 
                case op

                    # Branch baseops get translated into acf::BRANCH:
                    #
                    ( hbo::IS_BOXED  | hbo::IS_UNBOXED | hbo::CMP _ | hbo::POINTER_EQL
                    | hbo::POINTER_NEQ | hbo::POLY_EQL | hbo::POLY_NEQ
                    )
                        =>
                        acf::LET( [v],
                                  acf::BRANCH (baseop, vs, bool_lexp TRUE, bool_lexp FALSE),
                                  e
                                );

                    # baseops that take zero arguments;
                    # argument types must be void
                    #
                    ( hbo::GET_RUNTIME_ASM_PACKAGE_RECORD               # This appears to be dead code.
                    | hbo::GET_EXCEPTION_HANDLER_REGISTER
                    | hbo::GET_CURRENT_THREAD_REGISTER
                    | hbo::DEFLVAR                                      # This appears to be dead code.
                    )
                        =>
                        {   fun fix t
                                = 
                                hcf::if_uniqtype_is_arrow_type
                                  ( t, 
                                    fn (ff,[t1], ts2)
                                            =>
                                            if (hcf::same_uniqtyp (t1, hcf::void_uniqtyp)) 
                                                #
                                                hcf::make_typ_uniqtype (hcf::make_arrow_uniqtyp (ff, [], ts2));
                                            else
                                                bug "unexpected zero-args prims 1 in highcode_baseop";
                                            fi;

                                        _ => bug "highcodePrim: t1";
                                    end,

                                    fn _ =  bug "unexpected zero-args prims 2 in highcode_baseop"
                                  );

                            new_op_type
                                =
                                hcf::if_uniqtype_is_lambdacode_typeagnostic
                                  ( op_type, 
                                    fn (ks, t) =  hcf::make_lambdacode_typeagnostic_uniqtype (ks, fix t),
                                    fn _       =  fix op_type
                                  );

                            acf::BASEOP ((dictionary, op, new_op_type, arg_types), [], v, e);
                       };

                    _ =>   acf::BASEOP (baseop, vs, v, e);
                esac;

        end;                                    #  stipulate highcode_baseop 

        # force_raw freezes the calling conventions of a data constructor;
        # strictly used by the CON and VALCON only 
        #
        fun force_raw  pty
            = 
            if (hcf::uniqtype_is_lambdacode_typeagnostic  pty)
                #
                my (ks, body) =  hcf::unpack_lambdacode_typeagnostic_uniqtype   pty;
                my (aty, rty) =  hcf::unpack_lambdacode_arrow_uniqtype          body;

                hcf::make_lambdacode_typeagnostic_uniqtype
                  ( ks,
                    hcf::make_arrow_uniqtype
                      (
                        hcf::rawraw_variable_calling_convention,
                        [ m2m::ltc_raw  aty ],
                        [ m2m::ltc_raw  rty ]
                      )
                  );
            else 
                my (aty, rty)
                    =
                    hcf::unpack_lambdacode_arrow_uniqtype  pty;

                hcf::make_arrow_uniqtype
                  (
                    hcf::rawraw_variable_calling_convention,
                    [ m2m::ltc_raw  aty ],
                    [ m2m::ltc_raw  rty ]
                  );

            fi;                                 #  function force_raw 

        fun to_con  con
            =
            case con
                #
                lcf::INT_CASETAG     x =>  acf::INT_CASETAG     x;
                lcf::INT1_CASETAG   x =>  acf::INT1_CASETAG   x;
                lcf::UNT_CASETAG     x =>  acf::UNT_CASETAG     x;
                lcf::UNT1_CASETAG   x =>  acf::UNT1_CASETAG   x;
                lcf::FLOAT64_CASETAG x =>  acf::FLOAT64_CASETAG x;
                lcf::STRING_CASETAG  x =>  acf::STRING_CASETAG  x;
                lcf::VLEN_CASETAG    x =>  acf::VLEN_CASETAG    x;
                #
                lcf::INTEGER_CASETAG _ =>  bug "INTEGER_CASETAG" ;
                lcf::VAL_CASETAG     x =>  bug "unexpected case in to_con";
            esac;

        fun to_fun_dec
              ( venv,                           # Maps highcode variables to types;  initially empty.
                d,                              # Debruijn depth;  initially di::top.
                f_lv,                           # Fresh variable.
                arg_lv,                         # Arg to function.
                arg_lty,                        # Type of arg to function.
                body,                           # Body of function.
                loop_info                       # Initially FALSE.
              )
            =
            {   # First, we translate the body
                # (in the extended dictionary):
                # 
                my (body', body_lty)
                    =
                    to_lexp (hcf::set_uniqtype_for_var (venv, arg_lv, arg_lty, d), d)
                            body;

                # Detuple the arg type:
                # 
                (m2m::v_punflatten  arg_lty)
                    ->
                    ((arg_is_raw, arg_ltys, _), unflatten);
                    

                # Add tupling code at the beginning of the body:
                # 
                (unflatten (arg_lv, body'))
                    ->
                    (arg_lvs, body'');

                # Construct the return type if necessary:
                # 
                (m2m::t_pflatten  body_lty)
                    ->
                    (body_is_raw, body_ltys, _);

                rettype = if (not loop_info)  NULL;
                          else                THE (map m2m::ltc_raw body_ltys, acf::OTHER_LOOP);
                          fi;

                my (f_lty, fkind)
                    =
                    if (hcf::uniqtype_is_typ arg_lty and hcf::uniqtype_is_typ body_lty) 

                        # A function:
                        #
                        ( hcf::make_lambdacode_arrow_uniqtype (arg_lty, body_lty),

                          { loop_info         =>  rettype,
                            private =>  FALSE,
                            inlining_hint     =>  acf::INLINE_IF_SIZE_SAFE,
                            call_as           =>  acf::CALL_AS_FUNCTION (hcf::make_variable_calling_convention { arg_is_raw, body_is_raw })
                          }
                        );
                    else 
                        # A generic package:
                        # 
                        ( hcf::make_lambdacode_generic_package_uniqtype (arg_lty, body_lty),

                          { loop_info         =>  rettype,
                            private =>  FALSE,
                            inlining_hint     =>  acf::INLINE_IF_SIZE_SAFE,
                            call_as           =>  acf::CALL_AS_GENERIC_PACKAGE
                          }
                        );
                    fi;

                ( (fkind, f_lv, paired_lists::zip (arg_lvs, map m2m::ltc_raw arg_ltys), body''),
                  f_lty
                );
            }


        # Translate expressions whose structure is the same
        # in Anormcode as in lambdacode (either both naming or both non-naming)
        # a fate is unnecessary:
        #
        also
        fun to_lexp (venv, d) lambda_expression
            =
            {   fun default_to_values ()
                    =
                    to_values
                      ( venv,
                        d,
                        lambda_expression,
                        fn (vals, lambda_type)
                            =
                            (acf::RET vals, lambda_type)
                      );

                case lambda_expression
                    #
                    lcf::APPLY (lcf::BASEOP _, arg) => default_to_values();
                    lcf::APPLY (lcf::GENOP  _, arg) => default_to_values();

                    lcf::APPLY (lcf::FN (arg_lv, arg_lty, body), arg_le)
                        =>
                        to_lexp (venv, d) (lcf::LET (arg_lv, arg_le, body));

                    lcf::APPLY (f, arg)
                        =>
                        # First, evaluate f to a mere value:
                        # 
                        to_value
                          ( venv,
                            d,
                            f,
                            fn (f_val, f_lty)
                                =
                                # Then evaluate the argument:
                                #
                                to_values
                                  ( venv,
                                    d,
                                    arg,
                                    fn (arg_vals, arg_lty)
                                        =
                                        # Now find the return type:
                                        #
                                        {   my (_, r_lty)
                                                = 
                                                hcf::uniqtype_is_lambdacode_generic_package  f_lty
                                                    ??  hcf::unpack_lambdacode_generic_package_uniqtype    f_lty
                                                    ::  hcf::unpack_lambdacode_arrow_uniqtype  f_lty;

                                            # And finally do the call:
                                            # 
                                            (acf::APPLY (f_val, arg_vals), r_lty);
                                        }
                                  )
                          );

                    lcf::MUTUALLY_RECURSIVE_FNS (lvs, ltys, lexps, lambda_expression)
                        =>
                        # First, let's set up the enriched
                        # dictionary with those funs:
                        #
                        {   venv' = paired_lists::fold_forward
                                        (fn (lv, lambda_type, ve) = hcf::set_uniqtype_for_var (ve, lv, lambda_type, d))
                                        venv
                                        (lvs, ltys);

                             fun map3 _ ([], _, _) => [];
                                 map3 _ (_, [], _) => [];
                                 map3 _ (_, _, []) => [];

                                 map3 f (x ! xs, y ! ys, z ! zs)
                                     =>
                                     f (x, y, z) ! map3 f (xs, ys, zs);
                             end;

                             # Then translate each function in turn:
                             #   
                             funs = map3  fn (f_lv, f_lty, lcf::FN (arg_lv, arg_lty, body))
                                                 =>
                                                 #1 (to_fun_dec (venv', d, f_lv, arg_lv, arg_lty, body, TRUE));

                                               _ =>
                                                 bug "non-function in lcf::MUTUALLY_RECURSIVE_FNS";
                                          end

                                          (lvs, ltys, lexps);

                             # Finally, translate the Lambdacode_Expression:
                             #
                             my (lambda_expression', lambda_type)
                                 =
                                 to_lexp (venv', d) lambda_expression;

                             ( acf::MUTUALLY_RECURSIVE_FNS (funs, lambda_expression'),
                               lambda_type
                             );
                         };

                    lcf::LET (highcode_variable, lambda_expression1, lambda_expression2)
                        =>
                        to_lvar
                          ( venv,
                            d,
                            highcode_variable,
                            lambda_expression1,
                            fn lambda_type1
                                =
                                to_lexp
                                  ( hcf::set_uniqtype_for_var (venv, highcode_variable, lambda_type1, d),
                                    d
                                  )
                                  lambda_expression2
                          );

                    lcf::RAISE (le, r_lty)
                        => 
                        to_value
                          ( venv,
                            d,
                            le,
                            fn (le_val, le_lty)
                                =
                                {   my (_, r_ltys, _)
                                        =
                                        m2m::t_pflatten r_lty;

                                    ( acf::RAISE (le_val, map m2m::ltc_raw r_ltys),
                                      r_lty
                                    );
                                }
                          );

                    lcf::EXCEPT (body, handler)
                        =>
                        to_value
                          ( venv,
                            d,
                            handler,
                            fn (h_val, h_lty)
                                =
                                {   my (body', body_lty)
                                        =
                                        to_lexp (venv, d) body;

                                    (acf::EXCEPT (body', h_val), body_lty);
                                }
                          );

                    lcf::SWITCH (le, acs,[], NULL)
                        => bug "unexpected case in lcf::SWITCH";
                         #  to_value (venv, d, le, fn _ = (acf::RET[], [])) 

                    lcf::SWITCH (le, acs,[], THE lambda_expression)
                        =>
                        to_value
                          ( venv,
                            d,
                            le,
                            fn (v, lambda_type)
                                =
                                to_lexp
                                  (venv, d)
                                  lambda_expression
                          );

                    lcf::SWITCH (le, acs, conlexps, default)
                        =>
                        {   fun f (lcf::VAL_CASETAG((s, cr, lambda_type), typs, highcode_variable), le)
                                    =>
                                    {   my (lv_lty, _)
                                            =
                                            hcf::unpack_lambdacode_arrow_uniqtype
                                              (hcf::apply_typeagnostic_type_to_arglist_with_single_result
                                                  (lambda_type, typs)
                                              );

                                        newvenv = hcf::set_uniqtype_for_var (venv, highcode_variable, lv_lty, d);

                                        my (le, le_lty)
                                            =
                                            to_lexp (newvenv, d) le;

                                        ( ( acf::VAL_CASETAG
                                              ( (s, cr, force_raw  lambda_type),
                                                map m2m::tcc_raw  typs,
                                                highcode_variable
                                              ),
                                            le
                                          ),
                                          le_lty
                                        );
                                    };

                                f (con, le)
                                    =>
                                    {   (to_lexp (venv, d) le) ->   (lambda_expression, lambda_type);
                                        #
                                        ((to_con con, lambda_expression), lambda_type);
                                    };
                            end;

                            to_value
                              ( venv,
                                d,
                                le,
                                fn (v, lambda_type)
                                    =
                                    {   default  = null_or::map (#1 o to_lexp (venv, d)) default;
                                        conlexps = map f conlexps;
                                        lambda_type = #2 (list::head conlexps);
                                        (acf::SWITCH (v, acs, map #1 conlexps, default), lambda_type);
                                    }
                              );
                       };

                    # For mere values, use to_values:
                    # 
                    _ => default_to_values ();

                esac;
            }


        # tovalue: turns a lambdacode Lambdacode_Expression into a value+type and then calls
        # the fate that will turn it into an Anormcode Lambdacode_Expression+type
        # (ltyenv * debruijn_index * lcf::Lambdacode_Expression * ((value * Uniqtype) -> (acf::Lambdacode_Expression * Uniqtype list))) -> (acf::Lambdacode_Expression * Uniqtype)
        # 
        # - venv is the type dictionary for values
        # - conts is the fate
        #
        also
        fun to_value (venv, d, lambda_expression, fate)
            =
            {   case lambda_expression
                    #                  
                    # For simple values, it's trivial:
                    #    
                    lcf::VAR v
                        =>
                        fate (acf::VAR v, hcf::get_uniqtype_for_var (venv, v, d));

                    lcf::INT i
                        => 
                        {   i+i+2;                                      # Maybe trigger OVERFLOW exception.
                            fate (acf::INT i, hcf::int_uniqtype);
                        }
                        except
                            OVERFLOW
                                =
                                {   z  = i / 2;
                                    ne = lcf::APPLY (iadd_prim, lcf::RECORD [lcf::INT z, lcf::INT (i-z)]);
                                    to_value (venv, d, ne, fate);
                                };


                    lcf::UNT i
                        => 
                        {   max_unt = 0ux20000000;

                            if (unt::(<) (i, max_unt))
                                #
                                fate (acf::UNT i, hcf::int_uniqtype);
                            else
                                x1 = unt::(/) (i, 0u2);
                                x2 = unt::(-) (i, x1);

                                ne = lcf::APPLY (uadd_prim, lcf::RECORD [lcf::UNT x1, lcf::UNT x2]);

                                to_value (venv, d, ne, fate);
                            fi;
                        };

                    lcf::INT1   n =>  fate (acf::INT1   n, hcf::int1_uniqtype);
                    lcf::UNT1   n =>  fate (acf::UNT1   n, hcf::int1_uniqtype);
                    lcf::FLOAT64 x =>  fate (acf::FLOAT64 x, hcf::float64_uniqtype);
                    lcf::STRING  s =>  fate (acf::STRING  s, hcf::string_uniqtype);

                    # For cases where to_lvar is more convenient:
                    #    
                    _   => 
                        {   lv = make_var();
                            to_lvar
                              ( venv,
                                d,
                                lv,
                                lambda_expression,
                                fn lambda_type
                                    =
                                    fate (acf::VAR lv, lambda_type)
                              );
                        };
                esac;
            }



        # to_values: turns a lambdacode Lambdacode_Expression into a list of values and a list of types
        # and then calls the fate that will turn it into an Anormcode Lambdacode_Expression+type
        #
        # (ltyenv * debruijn_index * lcf::Lambdacode_Expression * ((value list * Uniqtype list) -> (acf::Lambdacode_Expression * Uniqtype list))) -> (acf::Lambdacode_Expression * Uniqtype)
        # 
        # - venv is the type dictionary for values
        # - fate is the fate
        #
        also
        fun to_values (venv, d, lambda_expression, fate)
            =
            {   1;

                case lambda_expression   

                    lcf::RECORD  lexps
                        =>
                        lexps2values
                          ( venv,
                            d,
                            lexps,
                            fn (vals, ltys)
                                =
                                {   lambda_type = hcf::make_tuple_uniqtype ltys;

                                    my (_, ltys, _)
                                        =
                                        m2m::t_pflatten lambda_type;

                                    # Detect the case where
                                    # flattening is trivial:
                                    # 
                                    if (hcf::same_uniqtype (lambda_type, hcf::make_tuple_uniqtype ltys) )

                                        fate (vals, lambda_type);
                                    else
                                        lv = make_var();

                                        my (_, pflatten)   = m2m::v_pflatten lambda_type; 
                                        my (vs, wrap)      = pflatten (acf::VAR lv);
                                        my (c_lexp, c_lty) = fate (vs, lambda_type);

                                        ( acf::RECORD (acj::rk_tuple, vals, lv, wrap c_lexp),
                                          c_lty
                                        );
                                    fi;
                                }
                          );

                    _   =>
                        to_value
                          ( venv,
                            d,
                            lambda_expression,
                            fn (v, lambda_type)
                                =
                                {   my (vs, wrap)
                                        =
                                        (#2 (m2m::v_pflatten lambda_type))  v;

                                    my (c_lexp, c_lty)
                                        =
                                        fate (vs, lambda_type);

                                 (wrap c_lexp, c_lty);
                                }
                          );
                esac;
            }

        # Evaluate each lambda_expression
        # to a value:
        # 
        also
        fun lexps2values (venv, d, lexps, fate)
            =
            f lexps ([], [])
            where

                fun f [] (vals, ltys)
                        =>
                        fate (reverse vals, reverse ltys);

                    f (lambda_expression ! lexps) (vals, ltys)
                        =>
                        to_value
                          ( venv,
                            d,
                            lambda_expression,
                            fn (v, lambda_type)
                                =
                                f lexps (v ! vals, lambda_type ! ltys)
                          );
                end;
            end


        # to_lvar: Same as to_value except that
        # it binds the value of the lambdacode
        # to the indicated Variable
        # and passes just the type to the continutation:
        #
        also
        fun to_lvar
               ( venv,
                 d,
                 highcode_variable,
                 lambda_expression,
                 fate
               )
            =
            {   fun eta_expand (f, f_lty)                                       # "eta-expansion" is the conversion   f   ->   fn x = f(x)
                    =                                                           # E.g., we do this to baseops because they are not legal function values in anormcode (unlike lambdacode).
                    {   lv = make_var();

                        my (arg_lty, ret_lty)                                   # Arg type and return type of 'f'.
                            =
                            (hcf::unpack_lambdacode_arrow_uniqtype f_lty);

                        to_lvar
                          ( venv,
                            d,
                            highcode_variable,
                            lcf::FN (lv, arg_lty, lcf::APPLY (f, lcf::VAR lv)),
                            fate
                          );
                    };

                # inbetween to_lvar and to_value:
                # it binds the lambda_expression
                # to a variable but is free to choose
                # the Variable and passes
                # it to the continutation:
                #
                fun to_lvarvalue (venv, d, lambda_expression, fate)
                    =
                    to_value
                      ( venv,
                        d,
                        lambda_expression,
                        fn (v, lambda_type)
                            =
                            case v
                                #
                                acf::VAR lv
                                    =>
                                    fate (lv, lambda_type);

                                _   =>
                                    {   lv = make_var();

                                        my (lambda_expression', lambda_type)
                                            =
                                            fate (lv, lambda_type);

                                        (acf::LET ([lv], acf::RET [v], lambda_expression'), lambda_type);
                                    };
                            esac
                      );

                fun baseop_helper (arg, f_lty, typs, filler)
                    =
                    # Invariants: baseop's
                    # types are always fully closed:
                    # 
                    {   # pty is the resulting highcode type of the underlying baseop,
                        # r_lty is the result lambdacode type of this baseop expression,
                        # and flat indicates whether we should flatten the arguments or not.
                        # The results of baseops are never flattened.
                        #
                        my (pty, r_lty, flat)
                            = 
                            case (hcf::uniqtype_is_lambdacode_typeagnostic f_lty, typs) 
                                #
                                (TRUE, _)               # Typeagnostic case.
                                    => 
                                    {   my (ks,  lt ) =  hcf::unpack_lambdacode_typeagnostic_uniqtype   f_lty;
                                        my (aty, rty) =  hcf::unpack_lambdacode_arrow_uniqtype  lt;

                                        r_lty
                                            = 
                                            hcf::apply_typeagnostic_type_to_arglist_with_single_result
                                              ( hcf::make_lambdacode_typeagnostic_uniqtype (ks, rty),
                                                typs
                                              );

                                        my (_, atys, flat) = m2m::t_pflatten aty; 

                                        # You really want to have a simpler
                                        # flattening heuristics here; in fact,
                                        # baseop can have its own flattening
                                        # strategy. The key is that baseop's 
                                        # type never escape outside.

                                        atys =  map  m2m::ltc_raw  atys;

                                        nrty =  m2m::ltc_raw rty;

                                        pty  =  hcf::make_arrow_uniqtype
                                                  (
                                                    hcf::rawraw_variable_calling_convention,
                                                    atys,
                                                    [ nrty ]
                                                  );

                                        ( hcf::make_lambdacode_typeagnostic_uniqtype (ks, pty),
                                          r_lty,
                                          flat
                                        );
                                    };

                                (FALSE, [])             # Typelocked case.
                                    =>
                                    {   my (aty,     rty ) =  hcf::unpack_lambdacode_arrow_uniqtype  f_lty;

                                        my (_, atys, flat) =  m2m::t_pflatten  aty;

                                        atys =  map  m2m::ltc_raw  atys;

                                        nrty =  m2m::ltc_raw  rty;

                                        pty  =  hcf::make_arrow_uniqtype
                                                  (
                                                    hcf::rawraw_variable_calling_convention,
                                                    atys,
                                                    [nrty]
                                                  );

                                        (pty, rty, flat);
                                    };

                                _ => bug "unexpected case in baseop_helper";
                            esac;

                      if flat 
                          #
                          # ZHONG asks: is the following definitely safe ?
                          # what would happen if ltc_raw is not an identity function ?
                          #
                          to_values
                            ( venv,
                              d,
                              arg,
                              fn (arg_vals, arg_lty)
                                  =
                                  {   my (c_lexp, c_lty)
                                          =
                                          fate (r_lty);

                                      # Put the filling inbetween:
                                      #  
                                      (filler (arg_vals, pty, c_lexp), c_lty);
                                  }
                            );  
                      else 
                          to_value
                            ( venv,
                              d,
                              arg,
                              fn (arg_val, arg_lty)
                                  =
                                  {   my (c_lexp, c_lty)
                                          =
                                          fate (r_lty);

                                      # Put the filling inbetween:
                                      # 
                                      (filler([arg_val], pty, c_lexp), c_lty);
                                  }
                            );
                      fi;   
                    };                  # fun baseop_helper 

                fun default_tolexp ()
                    =
                    {   my (lambda_expression', lambda_type)
                            =
                            to_lexp (venv, d) lambda_expression;

                        my (c_lexp, c_lty) =  fate (lambda_type);
                        my (_, punflatten) =  m2m::v_punflatten lambda_type; 
                        my (lvs, c_lexp' ) =  punflatten (highcode_variable, c_lexp);

                        (acf::LET (lvs, lambda_expression', c_lexp'), c_lty);
                    };

        #       fun default_to_value ()
        #           = 
        #           to_value
        #             ( venv,
        #               d,
        #               lambda_expression, 
        #               fn (v, lambdaType)
        #                   => 
        #                   let my (lambda_expression', ltys) = fate (lambdaType) 
        #                   in (acf::LET([highcode_variable], acf::RET[v], lambda_expression'), ltys) 
        #                   end) 

            
                case lambda_expression
                    #
                    # baseops have to be eta-expanded since they're not valid
                    # function values anymore in Anormcode

                    lcf::BASEOP   (_, lambda_type, typs) =>  eta_expand (lambda_expression, hcf::apply_typeagnostic_type_to_arglist_with_single_result (lambda_type, typs));
                    lcf::GENOP (_, _, lambda_type, typs) =>  eta_expand (lambda_expression, hcf::apply_typeagnostic_type_to_arglist_with_single_result (lambda_type, typs));

                    lcf::FN (arg_lv, arg_lty, body)
                        =>
                        # Translate the body with the extended 
                        # dictionary into a Function_Declaration:
                        #
                        {   my (function_declaration as (fk, f_lv, args, body'), f_lty)
                                =
                                to_fun_dec (venv, d, highcode_variable, arg_lv, arg_lty, body, FALSE);

                            my (lambda_expression, lambda_type)
                                =
                                fate  f_lty;

                            ( acf::MUTUALLY_RECURSIVE_FNS ( [function_declaration], lambda_expression),
                              lambda_type
                            );
                        };

                    # This is were we really deal with baseops:
                    # 
                    lcf::APPLY  (lcf::BASEOP (baseop, f_lty, typs),  arg)
                        =>
                        baseop_helper
                          ( arg,
                            f_lty,
                            typs,
                            fn (arg_vals, pty, c_lexp)
                                =
                                highcode_baseop
                                  ( (NULL, baseop, pty, map m2m::tcc_raw typs),
                                    arg_vals,
                                    highcode_variable,
                                    c_lexp
                                  )
                          );

                    lcf::APPLY (lcf::GENOP( { default, table }, baseop, f_lty, typs), arg)
                        =>
                        {   fun f ([], table, fate)
                                    =>
                                    fate (table);

                                f ((typs, le) ! t1, t2, fate)
                                    =>
                                    to_lvarvalue
                                      ( venv,
                                        d,
                                        le,
                                        fn (le_lv, le_lty)
                                            =
                                            f (t1, (map m2m::tcc_raw typs, le_lv) ! t2, fate)
                                      );
                            end;

                            # First, evaluate default:
                            # 
                            to_lvarvalue
                              ( venv,
                                d,
                                default,
                                fn (default_lv, default_lty)
                                    =
                                    # Then evaluate the table:
                                    # 
                                    f ( table,
                                        [],
                                        fn table'
                                            =
                                            baseop_helper
                                              ( arg,
                                                f_lty,
                                                typs,
                                                fn (arg_vals, pty, c_lexp)
                                                    =
                                                    highcode_baseop
                                                      ( ( THE { default => default_lv, 
                                                                table   => table'
                                                              },
                                                          baseop,
                                                          pty, 
                                                          map m2m::tcc_raw typs
                                                        ),
                                                        arg_vals,
                                                        highcode_variable,
                                                        c_lexp
                                                      )
                                              )
                                      )
                              );
                        };


                    lcf::TYPEFUN (tks, body)
                        =>
                        {   my (body', body_lty)
                                =
                                to_value
                                  ( venv,
                                    di::next d,
                                    body, 
                                    fn (le_val, le_lty)
                                        =
                                        (acf::RET [le_val], le_lty)
                                  );

                            lambda_type = hcf::make_lambdacode_typeagnostic_uniqtype (tks, body_lty);

                            my (lambda_expression', lambda_type)
                                =
                                fate (lambda_type);

                            args = map  (fn tk = (make_var(), tk))  tks;

                            ( acf::TYPEFUN
                                ( ( { inlining_hint => acf::INLINE_IF_SIZE_SAFE },
                                    highcode_variable,
                                    args,
                                    body'
                                  ),
                                  lambda_expression'
                                ),
                              lambda_type
                            );
                        };

                    lcf::APPLY_TYPEFUN (f, typs)
                        =>
                        # Similar to APPLY:
                        # 
                        to_value
                          ( venv,
                            d,
                            f,
                            fn (f_val, f_lty)
                                =
                                {   f_lty = hcf::apply_typeagnostic_type_to_arglist_with_single_result
                                                (f_lty, typs);

                                    my (c_lexp, c_lty)
                                        =
                                        fate (f_lty);

                                    ( acf::LET( [highcode_variable],
                                              acf::APPLY_TYPEFUN (f_val,  map  m2m::tcc_raw  typs),
                                              c_lexp
                                            ),
                                      c_lty
                                    );
                                }
                          );

                    lcf::EXCEPTION_TAG (le, lambda_type)
                        =>
                        to_value
                          ( venv,
                            d,
                            le,
                            fn (le_lv, le_lty)
                                =
                                {   my (c_lexp, c_lty)
                                        =
                                        fate (hcf::make_exception_tag_uniqtype lambda_type);

                                    make_exception_tag = acj::make__make_exception_tag (m2m::tcc_raw (hcf::unpack_typ_uniqtype lambda_type));

                                    ( highcode_baseop (make_exception_tag, [le_lv], highcode_variable, c_lexp),
                                      c_lty
                                    );
                                }
                          );

                    lcf::CONSTRUCTOR ((s, cr, lambda_type), typs, le)
                        =>
                        to_value
                          ( venv,
                            d,
                            le,
                            fn (v, _)
                                =
                                {   r_lty = hcf::apply_typeagnostic_type_to_arglist_with_single_result
                                                (lambda_type, typs);

                                    my (_,      v_lty) =   hcf::unpack_lambdacode_arrow_uniqtype  r_lty;
                                    my (c_lexp, c_lty) =   fate            v_lty;

                                    ( acf::CONSTRUCTOR
                                        ( (s, cr, force_raw lambda_type),
                                          map m2m::tcc_raw typs,
                                          v,
                                          highcode_variable,
                                          c_lexp
                                        ),

                                      c_lty
                                    );
                                }
                           );

                    lcf::VECTOR (lexps, typ)
                        =>
                        lexps2values
                          ( venv,
                            d,
                            lexps,
                            fn (vals, ltys)
                                =
                                {   lambda_type
                                        =
                                        hcf::make_typ_uniqtype  (hcf::make_ro_vector_uniqtyp  typ);

                                    my (c_lexp, c_lty)
                                        =
                                        fate (lambda_type);

                                    ( acf::RECORD
                                        ( acf::RK_VECTOR (m2m::tcc_raw typ),
                                          vals,
                                          highcode_variable,
                                          c_lexp
                                        ),
                                        c_lty
                                    );
                                }
                          );

                    lcf::RECORD lexps
                        =>
                        lexps2values
                          ( venv,
                            d,
                            lexps,
                            fn (vals, ltys)
                                =
                                {   lambda_type = hcf::make_tuple_uniqtype ltys;

                                    my (c_lexp, c_lty)
                                        =
                                        fate (lambda_type);

                                    (acf::RECORD (acj::rk_tuple, vals, highcode_variable, c_lexp), c_lty);
                                }
                          );

                    lcf::PACKAGE_RECORD lexps
                        =>
                        lexps2values
                          ( venv,
                            d,
                            lexps,
                            fn (vals, ltys)
                                =
                                {   lambda_type = hcf::make_package_uniqtype (ltys);

                                    my (c_lexp, c_lty)
                                        =
                                        fate  lambda_type;

                                    ( acf::RECORD
                                        ( acf::RK_PACKAGE,
                                          vals,
                                          highcode_variable,
                                          c_lexp
                                        ),

                                      c_lty
                                    );
                                }
                          );

                    lcf::GET_FIELD (n, lambda_expression)
                        =>
                        to_value
                          ( venv,
                            d,
                            lambda_expression,
                            fn (v, lambda_type)
                                =
                                {   lambda_type =  (hcf::lt_get_field (lambda_type, n));

                                    (fate  lambda_type) ->   (c_lexp, c_lty);

                                    ( acf::GET_FIELD (v, n, highcode_variable, c_lexp),
                                      c_lty
                                    );
                                }
                          );

                    lcf::PACK (lambda_type, otyps, ntyps, lambda_expression)
                        =>
                        bug "PACK is not currently supported";

            /*
                        to_value (venv, d, lambda_expression,
                                fn (v, v_lty) =>
                                let nlty = hcf::pmacroExpandPolymorephicLambdaTypeOrHOC (lambdaType, ntyps)
                                    my (c_lexp, c_lty) = fate (nlty)
                                in (acf::PACK (lambdaType,
                                           map m2m::tcc_raw otyps,
                                           map m2m::tcc_raw ntyps,
                                           v, highcode_variable, c_lexp),
                                    c_lty)
                                end)
            */

                  #  these ones shouldn't matter because they shouldn't appear 
            #        | lcf::WRAP _ => bug "unexpected WRAP in plambda" 
            #        | lcf::UNWRAP _ => bug "unexpected UNWRAP in plambda" 

                    _ => default_tolexp ();
                esac;
            };

        # We get invoked (only) from:
        #
        #     src/lib/compiler/toplevel/main/translate-raw-syntax-to-execode-g.pkg
        #
        fun translate_lambdacode_to_anormcode (lambda_expression as lcf::FN (arg_lv, arg_lty, e))
                =>
                #1 (to_fun_dec (hcf::empty_highcode_variable_to_uniqtype_map, di::top, make_var(), arg_lv, arg_lty, e, FALSE))
                except
                    x = raise exception x;

            translate_lambdacode_to_anormcode _
                =>
                bug "unexpected toplevel Lambdacode_Expression";
        end;
    };                                  # package translate_lambdacode_to_anormcode 
end;                                    # toplevel stipulate 


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext