PreviousUpNext

15.4.524  src/lib/compiler/debugging-and-profiling/profiling/profiling-dictionary-g.pkg

## profiling-dictionary-g.pkg

# Compiled by:
#     src/lib/compiler/debugging-and-profiling/debugprof.sublib


###       "The term 'bug' is used, to a limited extent,
###        to designate any fault or trouble in the
###        connections or working of electric apparatus."
###
###                        -- N Hawkin, 1896



# This generic is (only) invoked in:
#
#     src/lib/compiler/toplevel/compiler/mythryl-compiler-g.pkg
#
generic package   profiling_dictionary_g (
    #
    Dictionary;
    symbolmapstack_part:  Dictionary -> symbolmapstack::Symbolmapstack;
    evaluate:           (String, Dictionary) -> Dictionary;
    layer:              (Dictionary, Dictionary) -> Dictionary;
)
: Profiling_Dictionary                                                  # Profiling_Dictionary  is from   src/lib/compiler/debugging-and-profiling/profiling/profiling-dictionary.api
   where    Dictionary == Dictionary
=
package {

    Dictionary = Dictionary;

    package td = tell_dictionary;                                               # tell_dictionary       is from   src/lib/compiler/debugging-and-profiling/profiling/tell-env.pkg

    fun prof (e0:  td::Dictionary)
        =
        {   accum = REF (NIL: List( String ));
            fun say x = accum := x ! *accum;
            indentlev = REF 0;
            spaces = "                                            ";

            fun nl ()
                =
                {
                   say "\n";
                   say (substring (spaces, 0, int::min (size spaces, *indentlev)));
                };

            fun indent f x = { indentlev := *indentlev + 1;
                              f x;
                              indentlev := *indentlev - 1;};


            fun any_in_env e
                =
                list::exists any_in_naming (td::components e)

            also
            fun any_in_naming (_, b)
                =
                case (td::str_bind b,  td::val_bind b)
                    #
                    (THE str, _) =>  any_in_env  str;
                    (_, THE v)   =>  any_in_ty  v;
                    _            =>  FALSE;
                esac

            also
            fun any_in_ty type
                =
                case (td::fun_type type)
                    #
                    THE _ =>  TRUE;
                    NULL  =>  FALSE;
                esac;

            fun pr_env (e:  td::Dictionary)
                =
                apply pr_naming (td::components e)

            also
            fun pr_naming
                  (
                    symbol: td::Symbol,
                    b:      td::Naming
                  )
                =
                case  ( td::str_bind b,
                        td::val_bind b
                      )
                    (THE str, _) => pr_str (symbol, str);
                   (_, THE v) => pr_val (symbol, v);
                   _ => ();
                esac

            also
            fun pr_str
                  ( symbol:     td::Symbol,
                    e:          td::Dictionary
                  )
                =
                if (any_in_env e) 

                   say "package ";
                   say (td::name symbol); 
                   say " {"; nl();
                   say " include package ";
                   say (td::name symbol);
                   indent (\\ () = { nl(); pr_env e; }) ();
                   say "};"; nl();
                fi

            also
            fun pr_val
                  ( symbol:  td::Symbol,
                    type:    td::Typoid
                  )
                =
                {   fun curried (funid, argid, type)
                        =
                        case (td::fun_type type)
                            #
                            NULL =>
                                {   say "op ";
                                    say funid;
                                    say " ";
                                    say argid;
                                };

                            THE(_, type') =>
                                {
                                    say "stipulate my op f = op ";
                                    say funid;
                                    say " ";
                                    say argid;

                                    indent (\\() =  {   nl ();
                                                        say "herein \\ x => ";
                                                        curried ("f", "x", type');
                                                        nl ();
                                                        say "end";
                                                    }
                                            )
                                            ();
                                };
                        esac;

                    case (td::fun_type type)
                        #
                        THE(_, type') =>    {   say "my op ";
                                                say (td::name symbol);
                                                say " = \\ x => ";
                                                curried (td::name symbol, "x", type');
                                                nl ();
                                            };
                        _ => ();
                    esac;
                };

          pr_env e0;

          cat (reverse *accum);
        };

    fun replace { get_mapstack_set, set_mapstack_set }
        = 
        {   e0 = get_mapstack_set ();
            #
            s = prof (symbolmapstack_part e0);

            e1 = evaluate (s, e0);

            set_mapstack_set (layer (e1, e0));
        };


};



## COPYRIGHT (c) 1995 AT&T Bell Laboratories.
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext