PreviousUpNext

15.4.521  src/lib/compiler/back/top/translate/translate-deep-syntax-types-to-lambdacode.pkg

## translate-deep-syntax-types-to-lambdacode.pkg

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

# This is a dedicated support utility for translate_deep_syntax_to_lambdacode,
# the only package which references us:

#     src/lib/compiler/back/top/translate/translate-deep-syntax-to-lambdacode.pkg


###        "Every really new idea looks crazy at first."
###
###                      -- Alfred North Whitehead



stipulate
    package di  =  debruijn_index;                                              # debruijn_index                is from   src/lib/compiler/front/typer/basics/debruijn-index.pkg
    package hcf =  highcode_form;                                               # highcode_form                 is from   src/lib/compiler/back/top/highcode/highcode-form.pkg
    package hbt =  highcode_basetypes;                                          # highcode_basetypes            is from   src/lib/compiler/back/top/highcode/highcode-basetypes.pkg
    package hut =  highcode_uniq_types;                                         # highcode_uniq_types           is from   src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg
    package mld =  module_level_declarations;                                   # module_level_declarations     is from   src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg
    package trj =  typer_junk;                                                  # typer_junk                    is from   src/lib/compiler/front/typer/main/typer-junk.pkg
    package ty  =  types;                                                       # types                         is from   src/lib/compiler/front/typer-stuff/types/types.pkg
herein

    api Translate_Deep_Syntax_Types_To_Lambdacode {

        make_deep_syntax_to_lambdacode_type_translator
          :
          Void
          ->
          { deepsyntax_typpath_to_uniqkind:                             ty::Typ_Path    ->  hut::Uniqkind,
            deepsyntax_typpath_to_uniqtyp:      di::Debruijn_Depth ->   ty::Typ_Path    ->  hut::Uniqtyp,
            deepsyntax_type_to_uniqtyp:         di::Debruijn_Depth ->   ty::Type        ->  hut::Uniqtyp,
            deepsyntax_type_to_uniqtype:        di::Debruijn_Depth ->   ty::Type        ->  hut::Uniqtype,

            deepsyntax_package_to_uniqtype
              :
              ( mld::Package,
                di::Debruijn_Depth,
                trj::Per_Compile_Info
              )
              ->
              hut::Uniqtype,

            deepsyntax_generic_package_to_uniqtype
              :
              ( mld::Generic,
                di::Debruijn_Depth,
                trj::Per_Compile_Info
              )
              ->
              hut::Uniqtype,

            mark_letbound_typevar
              :
              ( di::Debruijn_Depth,
                Int
              )
              ->
              Int
          };

    };
end;

stipulate
    package bt  =  type_types;                                  # type_types                                    is from   src/lib/compiler/front/typer/types/type-types.pkg
    package da  =  varhome;                                     # varhome                                       is from   src/lib/compiler/front/typer-stuff/basics/varhome.pkg
    package di  =  debruijn_index;                              # debruijn_index                                is from   src/lib/compiler/front/typer/basics/debruijn-index.pkg
    package err =  error_message;                               # error_message                                 is from   src/lib/compiler/front/basics/errormsg/error-message.pkg
    package epc =  stamppath_context;                           # stamppath_context                             is from   src/lib/compiler/front/typer-stuff/modules/stamppath-context.pkg
    package ev  =  expand_generic;                              # expand_generic                                is from   src/lib/compiler/front/semantic/modules/expand-generic.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 hut =  highcode_uniq_types;                         # highcode_uniq_types                           is from   src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg
    package ins =  generics_expansion_junk;                     # generics_expansion_junk                       is from   src/lib/compiler/front/semantic/modules/generics-expansion-junk.pkg
    package ip  =  inverse_path;                                # inverse_path                                  is from   src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg
    package mj  =  module_junk;                                 # module_junk                                   is from   src/lib/compiler/front/typer-stuff/modules/module-junk.pkg
    package mld =  module_level_declarations;                   # module_level_declarations                     is from   src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg
    package syx =  symbolmapstack;                              # symbolmapstack                                is from   src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg
    package trd =  typer_debugging;                             # typer_debugging                               is from   src/lib/compiler/front/typer/main/typer-debugging.pkg
    package tro =  typerstore;                                  # typerstore                                    is from   src/lib/compiler/front/typer-stuff/modules/typerstore.pkg
    package tvi =  typevar_info;                                # typevar_info                                  is from   src/lib/compiler/front/semantic/types/typevar-info.pkg
    package ty  =  types;                                       # types                                         is from   src/lib/compiler/front/typer-stuff/types/types.pkg
    package tyj =  type_junk;                                   # type_junk                                     is from   src/lib/compiler/front/typer-stuff/types/type-junk.pkg
herein


    package   translate_deep_syntax_types_to_lambdacode
    : (weak)  Translate_Deep_Syntax_Types_To_Lambdacode         # Translate_Deep_Syntax_Types_To_Lambdacode     is from   src/lib/compiler/back/top/translate/translate-deep-syntax-types-to-lambdacode.pkg
    {
        fun bug msg
            =
            error_message::impossible ("translate_types: " + msg);

        say         =   global_controls::print::say; 
        debugging   =   global_controls::compiler::translate_types_debugging;

        fun if_debugging_say (msg: String)
            =
            if *debugging   { say msg; say "\n";};
            else            ();
            fi;

        debug_print
            =
            (fn x =  trd::debug_print debugging x);

        default_error
            =
            err::error_no_file (err::default_plaint_sink(), REF FALSE) line_number_db::null_region;

        stipulate

            package pp= prettyprint;    # prettyprint   is from   src/lib/prettyprint/big/src/prettyprint.pkg

        herein

            symbolmapstack = symbolmapstack::empty;

            fun prettyprint_type t
                = 
                (pp::with_prettyprint_device (err::default_plaint_sink())
                         (fn stream = {   pp::string stream "find: ";
                                          unparse_type::reset_unparse_type();
                                          unparse_type::unparse_type  symbolmapstack  stream  t;
                                      }
                )        )
                except _ = say "fail to print anything";


            fun prettyprint_type x
                = 
                (pp::with_prettyprint_device (err::default_plaint_sink ())
                          (fn stream =  {   pp::string stream "find: ";
                                            unparse_type::reset_unparse_type ();
                                            unparse_type::unparse_typ  symbolmapstack  stream  x;
                                        }
                          )
                )
                except
                    _ =  say "fail to print anything";
        end;

        #############################################################################
        #               TRANSLATING SOURCE-LANGUAGE TYPES INTO HIGHCODE TYPES       #
        #############################################################################
        stipulate

            rec_ty_context   =   REF [-1];

        herein 

            fun enter_rec_type (a)
                =
                (rec_ty_context := (a ! *rec_ty_context));

            fun exit_rec_type ()
                =
                (rec_ty_context := tail *rec_ty_context);

            fun rec_typ (i)
                = 
                {   x = head *rec_ty_context;
                    base = di::innermost;

                    if   (x == 0)   hcf::make_debruijn_typevar_uniqtyp (base, i);
                    elif (x >  0)   hcf::make_debruijn_typevar_uniqtyp (di::di_inner base, i);
                    else            bug "unexpected ty::RECURSIVE_TYPE";
                    fi;
                };

            fun free_typ (i)
                = 
                {   x    = head *rec_ty_context;
                    base = di::di_inner (di::innermost);

                    if   (x == 0)

                         hcf::make_debruijn_typevar_uniqtyp (base, i);

                    elif (x > 0)

                         hcf::make_debruijn_typevar_uniqtyp (di::di_inner base, i);
                    else
                         bug "unexpected ty::RECURSIVE_TYPE";
                    fi;
                };
        end;               #  end of recTypeConstructor and freeTypeConstructor hack 

                                                        # typevar_info          is from   src/lib/compiler/front/semantic/types/typevar-info.pkg

        fun deepsyntax_typpath_to_uniqkind (ty::TYPPATH_VARIABLE x)
                =>
                (tvi::get_typevar_info x).kind;

            deepsyntax_typpath_to_uniqkind _
                =>
                bug "unexpected Typ_Path parameters in deepsyntax_typpath_to_uniqkind";
        end;


        fun make_deep_syntax_to_lambdacode_type_translator ()
            = 
            { deepsyntax_typpath_to_uniqkind,
              deepsyntax_typpath_to_uniqtyp,
              deepsyntax_type_to_uniqtyp,
              deepsyntax_type_to_uniqtype,
              deepsyntax_package_to_uniqtype,
              deepsyntax_generic_package_to_uniqtype,
              mark_letbound_typevar
            }
            where
                nextmark =   REF 0;
                markmap  =   REF int_red_black_map::empty;

                # We are marking a LET-bound typevar as a reminder
                # to later convert it from most-general type (needed during typechecking)
                # to most-specific type (which allows better code optimization).
                #
                # We save the typevar's de Bruijn (depth, n) pair and
                # return a key via which we can later retrieve them. (See next fn.)
                #
                # This fn is (only) called from   translate_deep_syntax_to_lambdacode::translate_pattern_expression   in
                #
                #     src/lib/compiler/back/top/translate/translate-deep-syntax-to-lambdacode.pkg
                #
                fun mark_letbound_typevar
                    ( debruijn_depth:  di::Debruijn_Depth,
                      n:               Int
                    )
                    :                  Int
                    =
                    {   m = *nextmark;
                        #
                        nextmark :=  m + 1;
                        markmap  :=  int_red_black_map::set (*markmap, m, (debruijn_depth, n));
                        #
                        m;
                    };

                # Retrieve a (depth, n) pair stored via
                # the above mark_letbound_typevar fn:
                #
                fun find_letbound_typevar  mark
                    =
                    case (int_red_black_map::get (*markmap, mark))
                        #
                        THE v =>  v;
                        NULL  =>  error_message::impossible "transtypes: find_letbound_typevar";
                    esac;

                fun deepsyntax_typpath_to_uniqtyp d tp
                    = 
                    h (tp, d)
                    where
                        fun h (ty::TYPPATH_VARIABLE x, cur)
                                =>
                                {
                                    (tvi::get_typevar_info  x)
                                        ->
                                        { debruijn_depth, num, ... };
                                        

                                    hcf::make_debruijn_typevar_uniqtyp (di::subtract (cur, debruijn_depth), num);
                                };

                            h (ty::TYPPATH_TYP tc, cur)
                                =>
                                tyc_typ (tc, cur);

                            h (ty::TYPPATH_SELECT (tp, i), cur)
                                =>
                                hcf::make_ith_in_typeseq_uniqtyp (h(tp, cur), i);

                            h (ty::TYPPATH_APPLY (tp, ps), cur)
                                => 
                                hcf::make_apply_typefun_uniqtyp (h(tp, cur), map (fn x => h (x, cur); end ) ps);

                            h (ty::TYPPATH_GENERIC (ps, ts), cur) => 
                                {   ks = map deepsyntax_typpath_to_uniqkind ps;
                                    cur' = di::next cur;

                                    ts' =  map (fn x =  h (x, cur'))
                                               ts;

                                    hcf::make_typefun_uniqtyp (ks, hcf::make_typeseq_uniqtyp ts');
                                };
                        end;
                    end

                /*
                also tycTypeConstructor x = 
                  compile_statistics::do_phase (compile_statistics::make_phase "Compiler 043 1-tycTypeConstructor") tycTypeConstructor0 x
                */

                also
                fun tyc_typ (tc, d)
                    = 
                    g tc
                    where
                        fun dts_typ nd ( { constructor_list: List( ty::Constructor_Description ), arity=>i, ... }:  ty::Datatype_Member)
                            = 
                            {   nnd =    i == 0   ??            nd
                                                  ::   di::next nd;

                                fun f ( { domain=>NULL,   form, name }, r) =>   (hcf::void_uniqtyp  )              ! r;
                                    f ( { domain=>THE t,  form, name }, r) =>   (deepsyntax_type_to_uniqtyp nnd t) ! r;
                                end;

                                enter_rec_type i;
                                core   =   hcf::make_sum_uniqtyp (fold_backward f [] constructor_list);                                     
                                exit_rec_type();

                                result_typ
                                    =
                                    if (i == 0)
                                        #
                                        core;
                                    else
                                        ks =   hcf::n_plaintype_uniqkinds i;
                                        #
                                        hcf::make_typefun_uniqtyp (ks, core);
                                    fi;

                                ( hcf::make_n_arg_typ_fun_uniqkind i,
                                  result_typ
                                );
                            };

                        fun dts_fam (free_typs, fam as { members, ... }:  ty::Datatype_Family)
                            =
                            case (package_property_lists::dtf_ltyc fam)

                                THE (tc, od)
                                    =>
                                    hcf::change_depth_of_uniqtyp (tc, od, d);   # Invariant: tc contains no free variables 
                                                                                        # so change_depth_of_uniqtyp should have no effects.
                                NULL
                                    => 
                                    {   fun ttk (ty::PLAIN_TYP { arity, ... } )
                                                =>
                                                hcf::make_n_arg_typ_fun_uniqkind arity;

                                            ttk (ty::DEFINED_TYP { type_scheme=>ty::TYPE_SCHEME { arity=>i, ... }, ... } )
                                                =>
                                                hcf::make_n_arg_typ_fun_uniqkind i;

                                            ttk _
                                                =>
                                                bug "unexpected ttk in dts_fam";
                                        end;

                                        ks = map ttk free_typs;

                                        my (nd, header)
                                            = 
                                            case ks [] =>  (d,           fn t = t                );
                                                 _     =>  (di::next d,  fn t = hcf::make_typefun_uniqtyp (ks, t));
                                            esac;

                                        mbs = vector::fold_backward (!) NIL members;

                                        mtcs = map (dts_typ (di::next nd)) mbs;

                                        my (fks, fts)
                                            =
                                            paired_lists::unzip  mtcs;

                                        nft = case fts    [x] => x;
                                                           _  => hcf::make_typeseq_uniqtyp fts;
                                              esac;

                                        tc = header (hcf::make_typefun_uniqtyp (fks, nft)); 

                                        package_property_lists::set_dtf_ltyc (fam, THE (tc, d));

                                        tc;
                                    };
                            esac;

                  /*
                        fun dtsFam (_, { lambdatyc=REF (THE (tc, od)), ... } : Datatype_Family) =
                              hcf::change_depth_of_uniqtyp (tc, od, d) /* invariant: tc contains no free variables so change_depth_of_uniqtyp should have no effects */
                          | dtsFam (free_typs, { members, lambdatyc=x, ... } ) = 
                              let fun ttk (ty::PLAIN_TYP { arity, ... } ) = hcf::make_n_arg_typ_fun_uniqkind arity
                                    | ttk (ty::DEFINED_TYP { type_scheme=ty::TYPE_SCHEME { arity=i, ... }, ... } ) = hcf::make_n_arg_typ_fun_uniqkind i
                                    | ttk _ = bug "unexpected ttk in dtsFam"
                                  ks = map ttk free_typs
                                  my (nd, header) = 
                                    case ks of [] => (d, fn t => t)
                                             | _ => (di::next d, fn t => hcf::make_typefun_uniqtyp (ks, t))
                                  mbs = vector::fold_backward (!) NIL members
                                  mtcs = map (dtsTypeConstructor (di::next nd)) mbs
                                  my (fks, fts) = paired_lists::unzip mtcs
                                  nft = case fts of [x] => x | _ => hcf::make_typeseq_uniqtyp fts
                                  tc = header (hcf::make_typefun_uniqtyp (fks, nft)) 
                                  (x := THE (tc, d))
                               in tc
                              end
                  */

                        fun g (typ as ty::PLAIN_TYP { arity, kind, ... } )
                                =>
                                case kind   
                                    #
                                    k as ty::DATATYPE _
                                        =>
                                        tyj::typs_are_equal (typ, bt::ref_typ)
                                            ?? hcf::make_basetype_uniqtyp (hbt::basetype_ref)
                                            :: h (k, arity);

                                    k   => h (k, arity);
                                esac;

                            g (ty::DEFINED_TYP { type_scheme, ... } )
                                =>
                                tf_typ (type_scheme, d);

                            g (ty::RECURSIVE_TYPE i) => rec_typ  i;
                            g (ty::FREE_TYPE      i) => free_typ i;

                            g (ty::RECORD_TYP _)
                                =>
                                bug "unexpected ty::RECORD_TYP in tycTypeConstructor-g";

                            g (ty::TYP_BY_STAMPPATH { arity, path=>inverse_path::INVERSE_PATH ss, stamppath } )
                                => 
                                {   # say "*** Warning for compiler writers: TYP_BY_STAMPPATH ";
                                    # apply (fn x => (say (symbol::name x); say ".")) ss;
                                    # say " in translate: ";
                                    # say (stamppath::macroExpansionPathToString stamppath);
                                    # say "\n";

                                    if (arity > 0)  hcf::make_typefun_uniqtyp (hcf::n_plaintype_uniqkinds arity, hcf::truevoid_uniqtyp);
                                    else            hcf::truevoid_uniqtyp;
                                    fi;
                                };

                            g (ty::ERRONEOUS_TYP)
                                =>
                                bug "unexpected typ in tycTypeConstructor-g";
                        end

                        also
                        fun h (ty::BASE hbt, _)
                                =>
                                hcf::make_basetype_uniqtyp (hbt::basetype_from_int  hbt);

                            h (ty::DATATYPE { index, family, free_typs, stamps, root }, _)
                                => 
                                {   tc = dts_fam (free_typs, family);
                                    n = vector::length stamps; 
                                    #  invariant: n should be the length of family members 

                                    hcf::make_recursive_uniqtyp((n, tc, (map g free_typs)), index);
                                };

                            h (ty::ABSTRACT tc, 0)
                                =>
                                (g tc); 
                                /* >>> hcf::make_abstract_uniqtyp (g tc) <<< */ 

                            h (ty::ABSTRACT tc, n)
                                =>
                                (g tc); 
                                # >>> We tempoarily turned off the use of abstract typs in
                                #     the intermediate language; proper support of ML-like
                                #     abstract types in the IL may require changes to the
                                #     ML language. (ZHONG)
                                # let ks = hcf::n_plaintype_uniqkinds n
                                #    fun fromto (i, j) = if i < j then (i ! fromto (i+1, j)) else []
                                #    fs = fromto (0, n)
                                #    ts = map (fn i => hcf::make_debruijn_typevar_uniqtyp (di::innermost, i)) fs
                                #    b = hcf::make_apply_typefun_uniqtyp (tycTypeConstructor (tc, di::next d), ts)
                                # in hcf::make_typefun_uniqtyp (ks, hcf::make_abstract_uniqtyp b)
                                # end
                                # <<<

                            h (ty::FLEXIBLE_TYP tp, _)
                                =>
                                deepsyntax_typpath_to_uniqtyp d tp;

                            h (ty::FORMAL, _)
                                =>
                                bug "unexpected FORMAL kind in tycTypeConstructor-h";

                            h (ty::TEMP, _)
                                =>
                                bug "unexpected TEMP kind in tycTypeConstructor-h";
                        end;
                    end

                also
                fun tf_typ (ty::TYPE_SCHEME { arity=>0, body }, d)
                        =>
                        deepsyntax_type_to_uniqtyp d body;

                    tf_typ (ty::TYPE_SCHEME { arity, body }, d)
                        => 
                        {
                            ks = hcf::n_plaintype_uniqkinds arity;
                            hcf::make_typefun_uniqtyp (ks, deepsyntax_type_to_uniqtyp (di::next d) body);
                        };
                end 

                also
                fun deepsyntax_type_to_uniqtyp
                    (debruijn_depth: di::Debruijn_Depth)
                    (t:              ty::Type)
                    :                hut::Uniqtyp
                    = 
                    {
if_debugging_say "\ndeepsyntax_type_to_uniqtyp/TOP    in translate-deep-syntax-types-to-lambdacode.pkg";
                        result =  g t;
if_debugging_say "deepsyntax_type_to_uniqtyp/BOTTOM in translate-deep-syntax-types-to-lambdacode.pkg";
                        result;
                    }
                    where

                        # A pair-list mapping variables to types.
                        # This is a length-64 (max) cache with most
                        # recently used items sorted to front:
                        #
                        var_to_type_cache
                            =
                            REF ([]:  List( (Ref( ty::Type_Variable ), hut::Uniqtyp)) ); 

                        fun get_ref_typevar_type  (tv as { id => _, ref_typevar => type_ref })                          # "tv" == "type variable"
                            = 
                            search_cache (*var_to_type_cache, [], 0)
                            where
                                # Get var type from cache if present,
                                # otherwise compute it via 'h':
                                #
                                fun search_cache
                                       ( (vt as (type_ref', type)) ! rest,                                      # Remaining cache to check.  "vt" == "(type_var, type)"
                                         checked,                                                               # Cache cells already checked.
                                         checked_len                                                            # Length of previous.
                                       )
                                       => 
                                       if (type_ref' == type_ref)
                                            var_to_type_cache := vt ! ((reverse checked) @ rest);               # Move 'vt' to front of cache list.
                                            type;                                                               # Return cached type for tv.
                                       else
                                            search_cache (rest, vt ! checked, checked_len+1);
                                       fi;

                                    search_cache ([], checked, checked_len)
                                        =>
                                        {   tv_type = h *type_ref;                                              # 'tv' is not in our cache so compute its type honestly.
                                            checked = checked_len > 64  ??  tail checked  ::  checked;          # Idea seems to be to keep a 64-size cache, recently used stuff sorted to front.
                                            var_to_type_cache :=  (type_ref, tv_type) ! (reverse checked);
                                            tv_type;                            #
                                        };
                                end;
                            end

                                                                                                                # translate_deep_syntax_to_lambdacode   is from   src/lib/compiler/back/top/translate/translate-deep-syntax-to-lambdacode.pkg
                        also
                        fun h (ty::RESOLVED_TYPE_VARIABLE          t) =>  g t;
                            h (ty::META_TYPE_VARIABLE              _) =>  hcf::truevoid_uniqtyp;
                            h (ty::INCOMPLETE_RECORD_TYPE_VARIABLE _) =>  hcf::truevoid_uniqtyp;

                            h (ty::TYPE_VARIABLE_MARK m)                                                                # These TYPE_VARIABLE_MARK values get set in translate_deep_syntax_to_lambdacode::translate_pattern_expression().
                                =>
                                {   (find_letbound_typevar m) ->   (depth, num);
                                    #
                                    hcf::make_debruijn_typevar_uniqtyp (di::subtract (debruijn_depth, depth), num);
                                };

                            h _ => hcf::truevoid_uniqtyp;   #  ZHONG?   XXX BUGGO FIXME
                        end

                        also
                        fun g (ty::TYPE_VARIABLE_REF ref_typevar) => /* h *tv */ get_ref_typevar_type  ref_typevar;
                            g (ty::TYPCON_TYPE (ty::RECORD_TYP _, [])) => hcf::void_uniqtyp;
                            g (ty::TYPCON_TYPE (ty::RECORD_TYP _, ts)) => hcf::make_tuple_uniqtyp (map g ts);
                            g (ty::TYPCON_TYPE (typ, [])) => tyc_typ (typ, debruijn_depth);
                            g (ty::TYPCON_TYPE (ty::DEFINED_TYP { type_scheme, ... }, args)) => g (tyj::apply_type_scheme (type_scheme, args));

                            g (ty::TYPCON_TYPE (tc as ty::PLAIN_TYP { kind, ... }, ts))
                                =>
                                case (kind, ts)   
                                    #
                                    (ty::ABSTRACT _, ts)
                                         =>
                                         hcf::make_apply_typefun_uniqtyp (tyc_typ (tc, debruijn_depth), map g ts);

                                    (_, [t1, t2])
                                        =>
                                        if (tyj::typs_are_equal (tc, bt::arrow_typ) ) hcf::make_lambdacode_arrow_uniqtyp (g t1, g t2);
                                        else hcf::make_apply_typefun_uniqtyp (tyc_typ (tc, debruijn_depth), [g t1, g t2]);
                                        fi;

                                    _   => hcf::make_apply_typefun_uniqtyp (tyc_typ (tc, debruijn_depth), map g ts);
                                 esac;

                            g (ty::TYPCON_TYPE (typ, ts))
                                =>
                                hcf::make_apply_typefun_uniqtyp
                                  (
                                    tyc_typ (typ, debruijn_depth),
                                    map g ts
                                  );

                            g (ty::TYPE_SCHEME_ARG_I i)
                                =>
                                hcf::make_debruijn_typevar_uniqtyp (di::innermost, i);

                            g (ty::TYPE_SCHEME_TYPE _)  => bug "unexpected poly-type in toTypeConstructor";
                            g (ty::UNDEFINED_TYPE)      => bug "unexpected undef-type in toTypeConstructor";
                            g (ty::WILDCARD_TYPE)       => bug "unexpected wildcard-type in toTypeConstructor";
                        end;
                    end

                also
                fun deepsyntax_type_to_uniqtype d (ty::TYPE_SCHEME_TYPE { type_scheme=>ty::TYPE_SCHEME { arity=>0, body }, ... } )
                        =>
                        deepsyntax_type_to_uniqtype d body;

                    deepsyntax_type_to_uniqtype d (ty::TYPE_SCHEME_TYPE { type_scheme=>ty::TYPE_SCHEME { arity,    body }, ... } )
                        => 
                        {   ks = hcf::n_plaintype_uniqkinds arity;
                            hcf::make_typeagnostic_uniqtype (ks, [deepsyntax_type_to_uniqtype (di::next d) body]);
                        };

                    deepsyntax_type_to_uniqtype d x
                        =>
                        hcf::make_typ_uniqtype (deepsyntax_type_to_uniqtyp d x);
                end;

                #############################################################################
                #         TRANSLATING SOURCE-LANGUAGE MODULES INTO HIGHCODE TYPES           #
                #############################################################################

                fun spec_lty (elements, typerstore, depth, per_compile_info)
                    = 
                    g (elements, typerstore, [])
                    where
                        fun g ([], typerstore, ltys)
                                =>
                                reverse ltys;

                            g ((symbol, mld::TYP_IN_API _) ! rest, typerstore, ltys)
                                =>
                                g (rest, typerstore, ltys);

                            g ((symbol, mld::PACKAGE_IN_API { an_api, module_stamp, ... } ) ! rest, typerstore, ltys)
                                =>
                                {   typechecked_package
                                        =
                                        tro::find_package_by_module_stamp
                                            ( typerstore,
                                              module_stamp
                                            );

                                    lt = generics_expansion_lambdatype (an_api, typechecked_package, depth, per_compile_info);

                                    g (rest, typerstore, lt ! ltys);
                                };

                            g ((symbol, mld::GENERIC_IN_API { a_generic_api, module_stamp, ... } ) ! rest, typerstore, ltys)
                                => 
                                {   typechecked_package
                                        =
                                        tro::find_generic_by_module_stamp
                                            ( typerstore,
                                              module_stamp
                                            );

                                    lt = typechecked_generic_lty (a_generic_api, typechecked_package, depth, per_compile_info); 

                                    g (rest, typerstore, lt ! ltys);
                                };

                            g ((symbol, spec) ! rest, typerstore, ltys)
                                =>
                                {   if_debugging_say ">>spec_lty/g/TOP";

                                    fun transty type
                                        = 
                                        (mj::translate_type  typerstore type)
                                        except
                                            tro::UNBOUND
                                                =
                                                {   if_debugging_say " + spec_lty";

                                                    trd::with_internals
                                                        (fn () =
                                                            debug_print( "typerstore: ",
                                                                        (fn pps =
                                                                         fn ee = 
                                                                            unparse_package_language::unparse_typerstore pps (ee, syx::empty, 12)
                                                                        ),
                                                                        typerstore
                                                                       )
                                                        );

                                                    if_debugging_say (" + spec_lty: should have printed typerstore");

                                                    raise exception tro::UNBOUND;
                                                };


                                    fun mapty t
                                        =
                                        deepsyntax_type_to_uniqtype depth (transty t);


                                    case spec
                                        #
                                        mld::VALUE_IN_API { type, ... }
                                            => 
                                            g (rest, typerstore, (mapty type) ! ltys);

                                        mld::VALCON_IN_API
                                            {
                                              datatype => ty::VALCON
                                                              {
                                                                form => da::EXCEPTION _, 
                                                                type,
                                                                ...
                                                              },
                                              ...
                                            }
                                            => 
                                            {   argt =  bt::is_arrow_type  type
                                                            ??  #1 (hcf::unpack_lambdacode_arrow_uniqtype (mapty  type))
                                                            ::  hcf::void_uniqtype;

                                                g (rest, typerstore, (hcf::make_exception_tag_uniqtype argt) ! ltys);
                                            };

                                        mld::VALCON_IN_API { datatype => ty::VALCON _, ... }
                                            =>
                                            g (rest, typerstore, ltys);

                                        _ => bug "unexpected spec in spec_lty";
                                    esac;
                                };
                        end;
                    end

#               also
#                signLty (an_api, depth, per_compile_info)
#                    = 
#                 let fun h (BEGIN_API { kind=THE _, lambdaty=REF (THE (lt, od)), ... } ) = lt
#                            #  hcf::change_depth_of_uniqtype (lt, od, depth) 
#                       | h (an_api as BEGIN_API { kind=THE _, lambdaty as REF NULL, ... } ) = 
#                           # Invariant: we assum that all named APIs (kind=THE _) are
#                           # defined at top-level, outside any generic package definitions. (ZHONG)
#
#                            let my { typechecked_package = typechecked_package, typeConstructorPaths=typeConstructorPaths } = 
#                                  INS::doPkgFunParameterApi { an_api=sign, typerstore=tro::empty, depth=depth,
#                                                 inverse_path = inverse_path::INVERSE_PATH[], per_compile_info=per_compile_info,
#                                                 source_code_region=line_number_db::nullRegion }
#                                nd = di::next depth
#                                nlty = strMetaLty (an_api, typechecked_package, nd, per_compile_info)
#
#                                ks = map tpsKnd typeConstructorPaths
#                                lt = hcf::make_typeagnostic_uniqtype (ks, nlty)
#                             in lambdaty := THE (lt, depth); lt
#                            end
#                       | h _ = bug "unexpected an_api in signLty"
#                  in h an_api
#                 end


                also
                fun package_meta_lty (an_api, typechecked_package as { typerstore, ... }: mld::Typechecked_Package, depth, per_compile_info)
                    =
                    case (an_api, package_property_lists::generics_expansion_lambdatype typechecked_package)
                        #
                        (_, THE (lt, od))
                            =>
                            hcf::change_depth_of_uniqtype (lt, od, depth);

                        (mld::API { api_elements, ... }, NULL)
                            => 
                            {   ltys = spec_lty (api_elements, typerstore, depth, per_compile_info);

                                lt = /* case ltys of [] => hcf::int_uniqtype
                                                       | _ => */ hcf::make_package_uniqtype (ltys);

                                package_property_lists::set_generics_expansion_lty (typechecked_package, THE (lt, depth));
                                lt;
                            };

                       _ => bug "unexpected an_api and typechecked_package in strMetaLty";
                    esac

                also
                fun generics_expansion_lambdatype (an_api, typechecked_package:  mld::Typechecked_Package, depth, per_compile_info)
                    =
                    case (an_api, package_property_lists::generics_expansion_lambdatype typechecked_package)

                         (an_api, THE (lt, od))
                             =>
                             hcf::change_depth_of_uniqtype (lt, od, depth);

                         # Note: the code here is designed to improve the "deepsyntax_type_to_uniqtype" translation;
                         # by translating the api instead of the package, this can 
                         # potentially save time on str_lty. But it can increase the cost of
                         # other procedures. Thus we turn it off temporarily. (ZHONG)   XXX BUGGO FIXME
                         #
                         #      | (API { kind=THE _, ... }, { lambdaty, ... } ) =>
                         #             let sgt = signLty (an_api, depth, per_compile_info)
                         #                 # Invariant: we assum that all named APIs 
                         #                 # (kind=THE _) are defined at top-level, outside any 
                         #                 # generic package definitions. (ZHONG)
                         #                 #
                         #                 parameterTypes = INS::get_packages_typ_paths { an_api=sign, typechecked_package = typechecked_package,
                         #                         typerstore=tro::empty, per_compile_info=per_compile_info }
                         #                 lt = hcf::macroExpandTypeagnosticLambdaTypeOrHOC (sgt, map (tpsTypeConstructor depth) parameterTypes)
                         #              in lambdaty := THE (lt, depth); lt
                         #             end

                         _   => package_meta_lty (an_api, typechecked_package, depth, per_compile_info);
                    esac

                also
                fun typechecked_generic_lty (an_api, typechecked_package, debruijn_depth, per_compile_info)
                    = 
                    case (an_api, package_property_lists::typechecked_generic_lty typechecked_package, typechecked_package)
                        #
                        (an_api, THE (lt, od), _)
                            =>
                            hcf::change_depth_of_uniqtype (lt, od, debruijn_depth);

                        (  mld::GENERIC_API {   parameter_api, body_api, ... },
                            _,
                            {   generic_closure as mld::GENERIC_CLOSURE { typerstore=>symbolmapstack, ... }, ... }
                        )
                            =>
                            {   my  { typechecked_package => argument_typechecked_package,
                                      typ_paths
                                    }
                                    = 
                                    ins::do_generic_parameter_api
                                      {
                                        an_api             =>  parameter_api,
                                        typerstore         =>  symbolmapstack,
                                        inverse_path       =>  inverse_path::INVERSE_PATH [],
                                        source_code_region =>  line_number_db::null_region,
                                        debruijn_depth, 
                                        per_compile_info
                                      };

                                debruijn_depth' =  di::next  debruijn_depth;

                                param_lty
                                    =
                                    package_meta_lty
                                      ( parameter_api,
                                        argument_typechecked_package,
                                        debruijn_depth',
                                        per_compile_info
                                      );

                                ks =  map  deepsyntax_typpath_to_uniqkind  typ_paths;

                                body_typechecked_package
                                    = 
                                    ev::expand_generic
                                      ( typechecked_package,
                                        argument_typechecked_package,
                                        debruijn_depth',
                                        epc::init_context,
                                        ip::empty,
                                        per_compile_info
                                      );

                                body_lty
                                    =
                                    generics_expansion_lambdatype
                                      ( body_api,
                                        body_typechecked_package,
                                        debruijn_depth',
                                        per_compile_info
                                      );

                                lt = hcf::make_typeagnostic_uniqtype (ks, [hcf::make_generic_package_uniqtype([param_lty],[body_lty])]);

                                package_property_lists::set_typechecked_generic_lty (typechecked_package, THE (lt, debruijn_depth));

                                lt;
                            };

                        _ => bug "genericMacroExpansionLty";
                    esac

                also
                fun deepsyntax_package_to_uniqtype (pkg as mld::A_PACKAGE { an_api, typechecked_package, ... }, depth, per_compile_info)
                        =>
                        case (package_property_lists::generics_expansion_lambdatype  typechecked_package)

                             THE (lt, od)
                                 =>
                                 hcf::change_depth_of_uniqtype (lt, od, depth);

                             NULL
                                 =>
                                 {   lt = generics_expansion_lambdatype (an_api, typechecked_package, depth, per_compile_info);

                                     package_property_lists::set_generics_expansion_lty (typechecked_package, THE (lt, depth));
                                     lt;
                                 };
                        esac;

                    deepsyntax_package_to_uniqtype _
                        =>
                        bug "unexpected package in deepsyntax_package_to_uniqtype";
                end 

                also
                fun deepsyntax_generic_package_to_uniqtype (mld::GENERIC { a_generic_api,  typechecked_generic, ... }, depth, per_compile_info)
                        =>
                        case (package_property_lists::typechecked_generic_lty  typechecked_generic)
                            #
                            THE (lt, od)
                                =>
                                hcf::change_depth_of_uniqtype (lt, od, depth);

                            NULL
                                =>
                                {   lt = typechecked_generic_lty (a_generic_api,  typechecked_generic, depth, per_compile_info);

                                    package_property_lists::set_typechecked_generic_lty (typechecked_generic, THE (lt, depth));
                                    lt;
                                };
                        esac;

                    deepsyntax_generic_package_to_uniqtype _ => bug "unexpected generic package in deepsyntax_generic_package_to_uniqtype";
                end;

                /****************************************************************************
                 *           A HASH-CONSING VERSION OF THE ABOVE TRANSLATIONS               *
                 ****************************************************************************/

                /*
                package mi_dictionary
                    =
                    red_black_map_g (pkg type Key = stampmapstack::modId
                                                     compare = stampmapstack::cmp
                                              end)
                */

                /*
                      m1 = REF (MIDict::mkDict())   #  modid (Type) -> hut::Uniqtyp 
                      m2 = REF (MIDict::mkDict())   #  modid (str/fct) -> hut::Uniqtype 

                      fun tycTypeConstructorLook (t as (ty::PLAIN_TYP _ | ty::DEFINED_TYP _), d) = 
                            let tid = mj::type_identifier t
                             in (case MIDict::peek (*m1, tid)
                                  of THE (t', od) => hcf::change_depth_of_uniqtyp (t', od, d)
                                   | NULL => 
                                       let x = tycTypeConstructor (t, d)
                                           (m1 := TcDict::set (*m1, tid, (x, d)))
                                        in x
                                       end)
                            end
                        | tycTypeConstructorLook x = tycTypeConstructor tycTypeConstructorLook x

                /*
                      toTypeConstructor = toTypeConstructor tycTypeConstructorLook
                      deepsyntax_type_to_uniqtype = toTypeConstructor tycTypeConstructorLook
                */
                      coreDict = (toTypeConstructor, deepsyntax_type_to_uniqtype)

                      fun strLtyLook (s as A_PACKAGE _, d) = 
                            let sid = mj::package_identifier s
                             in (case MIDict::peek (*m2, sid)
                                  of THE (t', od) => hcf::change_depth_of_uniqtype (t', od, d)
                                   | NULL => 
                                       let x = strLty (coreDict, strLtyLook, 
                                                           genericLtyLook) (s, d)
                                           (m2 := TcDict::set (*m2, sid, (x, d)))
                                        in x
                                       end)
                            end
                        | strLtyLook x = strLty (coreDict, strLtyLook, genericLtyLook)

                      also
                      genericLtyLook (f as GENERIC _, d)
                          = 
                          let fid = generic_identifier f
                          in
                              (   case MIDict::peek (*m2, fid)

                                    of THE (t', od)
                                       =>
                                       hcf::change_depth_of_uniqtype (t', od, d)

                                     | NULL
                                       => 
                                       let x = genericLty (tycTypeConstructorLook, strLtyLook, 
                                                           genericLtyLook) (s, d)
                                           (m2 := TcDict::set (*m2, fid, (x, d)))
                                       in x
                                       end
                              )
                          end
                        | genericLtyLook x = genericLty (coreDict, strLtyLook, genericLtyLook)
                */


              end;                                              # fun make_deep_syntax_to_lambdacode_type_translator
    };                                                          # package translate_types 
end;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext