PreviousUpNext

15.4.514  src/lib/compiler/back/top/nextcode/prettyprint-nextcode.pkg

## prettyprint-nextcode.pkg 

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


stipulate
    package ncf =  nextcode_form;                               # nextcode_form                 is from   src/lib/compiler/back/top/nextcode/nextcode-form.pkg
    package hut =  highcode_uniq_types;                         # highcode_uniq_types           is from   src/lib/compiler/back/top/highcode/highcode-uniq-types.pkg
    package iht =  int_hashtable;                               # int_hashtable                 is from   src/lib/src/int-hashtable.pkg
    package ppr =  prettyprinter;                               # prettyprinter                 is from   src/lib/prettyprint/big/src/prettyprinter.pkg
herein

    api Prettyprint_Nextcode {
       #
       prettyprint_nextcode                                     # This entrypoint is not currently called from outside this file.
           :
           (ncf::Function, iht::Hashtable( hut::Uniqtype) )
           ->
           Void;

       print_nextcode_expression:  ncf::Instruction     -> Void;
       print_nextcode_function:    ncf::Function        -> Void;

       prettyprint_nextcode_function
           :
           ppr::Prettyprinter 
           ->
           ncf::Function
           ->
           Void;

    };
end;


stipulate
    package ncf =  nextcode_form;                               # nextcode_form                 is from   src/lib/compiler/back/top/nextcode/nextcode-form.pkg
    package tmp =  highcode_codetemp;                           # highcode_codetemp             is from   src/lib/compiler/back/top/highcode/highcode-codetemp.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 iht =  int_hashtable;                               # int_hashtable                 is from   src/lib/src/int-hashtable.pkg
    package pp  =  prettyprint;                                 # prettyprint                   is from   src/lib/prettyprint/big/src/prettyprint.pkg
herein

    package   prettyprint_nextcode
    : (weak)  Prettyprint_Nextcode
    {

        say =  global_controls::print::say;

        fun numkind_name (ncf::p::INT   bits) =>  "i" + int::to_string bits;
            numkind_name (ncf::p::UNT   bits) =>  "u" + int::to_string bits;
            numkind_name (ncf::p::FLOAT bits) =>  "f" + int::to_string bits;
        end;

        fun looker_name  ncf::p::GET_REFCELL_CONTENTS                           =>  "get_refcell_contents";
            looker_name  ncf::p::GET_EXCEPTION_HANDLER_REGISTER                 =>  "get_exception_handler";
            looker_name  ncf::p::GET_VECSLOT_CONTENTS                           =>  "subscript";
            looker_name (ncf::p::GET_VECSLOT_NUMERIC_CONTENTS { kindbits } )    =>  ("numsubscript" + numkind_name kindbits);
            looker_name  ncf::p::GET_RUNTIME_ASM_PACKAGE_RECORD                 =>  "getrunvec";
            looker_name  ncf::p::GET_CURRENT_THREAD_REGISTER                    =>  "get_current_thread_register";
            looker_name  ncf::p::DEFLVAR                                        =>  "deflvar";
            looker_name  ncf::p::GET_STATE_OF_WEAK_POINTER_OR_SUSPENSION        =>  "get_state_of_weak_pointer_or_suspension";
            looker_name  ncf::p::PSEUDOREG_GET                                  =>  "getpseudo";
            looker_name (ncf::p::GET_FROM_NONHEAP_RAM { kindbits } )            =>  ("rawload" + numkind_name kindbits);
        end;

        fun branch_name  ncf::p::IS_BOXED   => "boxed";
            branch_name  ncf::p::IS_UNBOXED => "unboxed";
            branch_name (ncf::p::COMPARE { op, kindbits } )
                =>
                numkind_name kindbits
                +
                case op
                    #                  
                    ncf::p::GT  =>  ">";  
                    ncf::p::LT  =>  "<";
                    ncf::p::GE  =>  ">="; 
                    ncf::p::LE  =>  "<=";
                    ncf::p::EQL =>  "=";
                    ncf::p::NEQ =>  "!=";
                esac; 

            branch_name (ncf::p::COMPARE_FLOATS { op, size } )
                => 
                numkind_name (ncf::p::FLOAT size)
                +
                case op
                    #                  
                    ncf::p::f::EQ   => "=";
                    ncf::p::f::ULG  => "?<>";
                    ncf::p::f::GT   => ">";
                    ncf::p::f::GE   => ">=";
                    ncf::p::f::LT   => "<";
                    ncf::p::f::LE   => "<=";
                    ncf::p::f::LG   => "<>";
                    ncf::p::f::LEG  => "<=>";
                    ncf::p::f::UGT  => "?>";
                    ncf::p::f::UGE  => "?>=";
                    ncf::p::f::ULT  => "?<";
                    ncf::p::f::ULE  => "?<=";
                    ncf::p::f::UE   => "?=";
                    ncf::p::f::UN   => "?";
                esac;

            branch_name ncf::p::POINTER_NEQ   =>  "pointer_neq";
            branch_name ncf::p::POINTER_EQL   =>  "pointer_eql";

            branch_name ncf::p::STRING_EQL  =>  "string_eql";
            branch_name ncf::p::STRING_NEQ =>  "string_neq";
        end;

        fun setter_name  ncf::p::SET_VECSLOT_TO_TAGGED_INT_VALUE                        =>  "set_vecslot_to_tagged_int_value";
            setter_name  ncf::p::SET_VECSLOT_TO_BOXED_VALUE                     =>  "set_vecslot_to_boxed_value";
            setter_name  ncf::p::SET_VECSLOT                                    =>  "set_vecslot";
            setter_name (ncf::p::SET_VECSLOT_TO_NUMERIC_VALUE { kindbits } )    =>  ("set_vecslot_to_numeric_value" + numkind_name kindbits);
            setter_name  ncf::p::SET_REFCELL_TO_TAGGED_INT_VALUE                        =>  "set_refcell_to_tagged_int_value";
            setter_name  ncf::p::SET_REFCELL                                    =>  "set_refcell";
            setter_name  ncf::p::SET_EXCEPTION_HANDLER_REGISTER                 =>  "set_exception_handler_register";
            setter_name  ncf::p::SET_CURRENT_THREAD_REGISTER                    =>  "set_current_thread_register";
            setter_name  ncf::p::USELVAR                                        =>  "uselvar";
            setter_name  ncf::p::FREE                                           =>  "free";
            setter_name  ncf::p::SET_STATE_OF_WEAK_POINTER_OR_SUSPENSION        =>  "set_state_of_weak_pointer_or_suspension";
            setter_name  ncf::p::PSEUDOREG_SET                                  =>  "setpseudo";
            setter_name  ncf::p::SETMARK                                        =>  "setmark";
            setter_name  ncf::p::ACCLINK                                        =>  "acclink";
            setter_name (ncf::p::SET_NONHEAP_RAM { kindbits } )                 =>  ("set_raw_ram" + numkind_name kindbits);
            setter_name (ncf::p::SET_NONHEAP_RAMSLOT cty)                               =>  ("set_rawslot" + ncf::cty_to_string cty);
        end;

        cvt_param =  int::to_string;

        fun cvt_params (from, to)
            =
            cat [cvt_param from, "_", cvt_param to];

        fun arith_name (ncf::p::MATH { op, kindbits } )
                =>
                case op
                    #                  
                    ncf::p::ADD       =>  "+";
                    ncf::p::SUBTRACT  =>  "-"; 
                    ncf::p::MULTIPLY  =>  "*";
                    ncf::p::DIVIDE    =>  "/";
                    ncf::p::NEGATE    =>  "-_";
                    ncf::p::ABS       =>  "abs"; 
                    ncf::p::FSQRT     =>  "fsqrt"; 
                    ncf::p::FSIN      =>  "sin";
                    ncf::p::FCOS      =>  "cos";
                    ncf::p::FTAN      =>  "tan";
                    ncf::p::RSHIFT    =>  "rshift";
                    ncf::p::RSHIFTL   =>  "rshiftl";
                    ncf::p::LSHIFT    =>  "lshift";
                    ncf::p::BITWISE_AND      =>  "bitwise_and";
                    ncf::p::BITWISE_OR       =>  "bitwise_or";
                    ncf::p::BITWISE_XOR      =>  "bitwise_xor";
                    ncf::p::BITWISE_NOT      =>  "bitwise_not";
                    ncf::p::REM       =>  "rem";
                    ncf::p::DIV       =>  "div";
                    ncf::p::MOD       =>  "mod";
                 esac
                 +
                 numkind_name  kindbits;

            arith_name (ncf::p::SHRINK_INT arg)   => "test_"     +  cvt_params arg;
            arith_name (ncf::p::SHRINK_UNT arg)  => "testu_"    +  cvt_params arg;
            arith_name (ncf::p::SHRINK_INTEGER i) => "test_inf_" +  cvt_param i;

            arith_name (ncf::p::ROUND { floor=>TRUE, from=>ncf::p::FLOAT 64, to=>ncf::p::INT 31 } )
                =>
                "floor";

            arith_name (ncf::p::ROUND { floor=>FALSE, from=>ncf::p::FLOAT 64, to=>ncf::p::INT 31 } )
                =>
                "round";

            arith_name (ncf::p::ROUND { floor, from, to } )
                =>
                if floor  "floor"; else "round"; fi
                +
                numkind_name from
                +
                "_"
                +
                numkind_name to;
        end;

        fun pure_name  ncf::p::VECTOR_LENGTH_IN_SLOTS         =>  "vector_length_in_slots";
            pure_name (ncf::p::PURE_ARITH x)  =>  arith_name (ncf::p::MATH x);
            pure_name  ncf::p::HEAPCHUNK_LENGTH_IN_WORDS    =>  "heapchunk_length_in_words";
            pure_name  ncf::p::MAKE_REFCELL        =>  "makeref";
            pure_name (ncf::p::STRETCH arg)    =>  "extend_" + cvt_params arg;
            pure_name (ncf::p::COPY arg)      =>  "copy_" + cvt_params arg;
            pure_name (ncf::p::CHOP arg)     =>  "trunc_" + cvt_params arg;
            pure_name (ncf::p::CHOP_INTEGER  i)  =>  "trunc_inf_" + cvt_param i;
            pure_name (ncf::p::COPY_TO_INTEGER   i)  =>  cat ["copy_", cvt_param i, "_inf"];
            pure_name (ncf::p::STRETCH_TO_INTEGER i)  =>  cat ["extend_", cvt_param i, "_inf"];

            pure_name  ncf::p::GET_RO_VECSLOT_CONTENTS     => "subscriptv";
            pure_name  ncf::p::GET_BATAG_FROM_TAGWORD         => "get_batag_from_tagword";
            pure_name  ncf::p::MAKE_WEAK_POINTER_OR_SUSPENSION   => "make_weak_pointer_or_suspension";

            pure_name  ncf::p::WRAP             => "wrap";
            pure_name  ncf::p::UNWRAP           => "unwrap";

            pure_name  ncf::p::CAST             => "cast";
            pure_name  ncf::p::GETCON           => "getcon";
            pure_name  ncf::p::GETEXN           => "getexn";

            pure_name  ncf::p::WRAP_FLOAT64     => "wrap_float64";
            pure_name  ncf::p::UNWRAP_FLOAT64   => "funwrap_float64";

            pure_name  ncf::p::IWRAP            => "iwrap";
            pure_name  ncf::p::IUNWRAP          => "iunwrap";

            pure_name  ncf::p::WRAP_INT1                => "wrap_int1";
            pure_name  ncf::p::UNWRAP_INT1      => "unwrap_int1";

            pure_name  ncf::p::GETSEQDATA       => "getseqdata";
            pure_name  ncf::p::GET_RECSLOT_CONTENTS   => "get_recslot_contents";
            pure_name  ncf::p::GET_RAW64SLOT_CONTENTS => "get_raw64slot_contents";
            pure_name  ncf::p::MAKE_ZERO_LENGTH_VECTOR      => "make_zero_length_vector";
            pure_name (ncf::p::ALLOT_RAW_RECORD rk)  => "rawrecord_" + the_else (null_or::map rkstring rk, "notag");
            pure_name (ncf::p::CONDITIONAL_LOAD b)    => "conditional_move " + branch_name b;

            pure_name (ncf::p::PURE_GET_VECSLOT_NUMERIC_CONTENTS { kindbits } )
                =>
                ("numsubscriptv" + numkind_name kindbits);

            pure_name (ncf::p::CONVERT_FLOAT { from=>ncf::p::FLOAT 64, to=>ncf::p::INT 31 } )
                => "convert_float";

            pure_name (ncf::p::CONVERT_FLOAT { from, to } )
                =>
                ( "convert_float"
                + numkind_name  from
                + "_"
                + numkind_name  to
                );
        end 

        also
        fun rkstring rk
            =
            case rk 
                #             
                ncf::rk::VECTOR             =>  "ncf::rk::VECTOR";
                ncf::rk::RECORD             =>  "ncf::rk::RECORD";
                ncf::rk::SPILL              =>  "ncf::rk::SPILL";
                ncf::rk::NEXT_FN            =>  "ncf::rk::NEXT_FN";
                ncf::rk::FLOAT64_NEXT_FN    =>  "ncf::rk::FLOAT64_NEXT_FN";
                ncf::rk::PUBLIC_FN          =>  "ncf::rk::PUBLIC_FN";
                ncf::rk::PRIVATE_FN         =>  "ncf::rk::PRIVATE_FN";
                ncf::rk::FLOAT64_BLOCK      =>  "ncf::rk::FLOAT64_BLOCK";
                ncf::rk::INT1_BLOCK         =>  "ncf::rk::INT1_BLOCK";
            esac;


        fun show0 say
            =
            {   fun sayc ('\n') =>  say "\\n";
                    sayc c      =>  say (string::from_char c);
                end;

                fun sayv (ncf::CODETEMP     v) =>  say (tmp::name_of_highcode_codetemp v);
                    sayv (ncf::LABEL   v) =>  say ("(L)" + tmp::name_of_highcode_codetemp v);
                    sayv (ncf::INT     i) =>  say ("(I)" + int::to_string i);
                    sayv (ncf::INT1   i) =>  say ("(I32)" + one_word_unt::to_string i);
                    sayv (ncf::FLOAT64 r) =>  say r;
                    sayv (ncf::STRING  s) =>  { say "\"";   apply sayc (explode s);   say "\""; };
                    sayv (ncf::CHUNK   _) =>  say ("(chunk)");
                    sayv (ncf::TRUEVOID ) =>  say ("(truevoid)");
                end;

                fun sayvlist [v]      =>  sayv v;
                    sayvlist NIL      =>  ();
                    sayvlist (v ! vl) =>  { sayv v;   say ", ";   sayvlist vl; };
                end;


                fun sayrk (ncf::rk::RECORD, n) => ();
                    sayrk (ncf::rk::VECTOR, n) => ();
                    sayrk (k, n:  Int)
                        =>
                        {    say (rkstring k);
                             say " ";
                             say (int::to_string n);
                             say ", ";
                        };
                end;

                sayt = say o ncf::cty_to_string;

                fun sayparam ([v],[ct])        =>  { sayv v;   sayt ct; };
                    sayparam (NIL, NIL)        =>  ();
                    sayparam (v ! vl, ct ! cl) =>  { sayv v;   sayt ct;   say ", ";   sayparam (vl, cl); };
                    sayparam _                 =>  error_message::impossible "sayparam in prettyprint-nextcode.pkg";
                end;

                fun saypath (ncf::SLOT 0) => ();
                    saypath (ncf::SLOT i) => { say "+"; say (int::to_string i);};
                    #
                    saypath (ncf::VIA_SLOT (j, p))
                        =>
                        {   say ".";
                            say (int::to_string j);
                            saypath p;
                        };
                end;

                fun sayvp (v, path)
                    =
                    {   sayv v;
                        saypath path;
                    };

                fun saylist f [x]     =>   f x;
                    saylist f NIL     => (); 
                    saylist f (x ! r) =>  { f x;  say ", ";  saylist f r;};
                end;

                fun indent n
                    =
                    f
                    where
                        fun space 0 => ();
                            space k => { say " ";  space (k - 1); };
                        end;

                        fun nl () = say "\n";

                        recursive my f
                            =
                            fn  ncf::DEFINE_RECORD { kind, fields, to_temp, next }
                                    =>
                                    {   space n;

                                        case kind
                                            #
                                            ncf::rk::VECTOR =>  say "#{ ";
                                            _               =>  say  "{ ";
                                        esac;

                                        sayrk (kind, length fields);
                                        saylist sayvp fields;
                                        say "} -> ";
                                        sayv (ncf::CODETEMP to_temp);
                                        nl();
                                        f next;
                                    };

                                ncf::GET_FIELD_I { i, record, to_temp, type, next }
                                    =>
                                    {   space n;
                                        sayv record;
                                        say ".";
                                        say (int::to_string i);
                                        say " -> ";
                                        sayv (ncf::CODETEMP to_temp);
                                        sayt type;
                                        nl();
                                        f next;
                                    };

                                ncf::GET_ADDRESS_OF_FIELD_I { i, record, to_temp, next }
                                    =>
                                    {   space n;
                                        sayv record;
                                        say "+";
                                        say (int::to_string i);
                                        say " -> ";
                                        sayv (ncf::CODETEMP to_temp);
                                        nl();
                                        f next;
                                    };

                                ncf::TAIL_CALL { func, args }
                                    =>
                                    {   space n;
                                        sayv func;
                                        say "(";
                                        sayvlist args;
                                        say ")\n";
                                    };

                                ncf::DEFINE_FUNS { funs, next }
                                    =>
                                    {   apply g funs;
                                        f next;
                                    }
                                    where
                                        fun g (_, v, wl, cl, d)
                                            = 
                                            {   space n;
                                                sayv (ncf::CODETEMP v);
                                                say "("; 
                                                sayparam (map ncf::CODETEMP wl, cl);
                                                say ") =\n"; 
                                                indent (n+3) d;
                                            };
                                    end;

                                ncf::JUMPTABLE { i, xvar, nexts }
                                    =>
                                    {   fun g (i, c ! cl)
                                                =>
                                                {   space (n+1);
                                                    say (int::to_string (i: Int));
                                                    say " =>\n";
                                                    indent (n+3) c;
                                                    g (i+1, cl);
                                                };
                                            g (_, NIL)
                                                =>
                                                ();
                                        end;

                                        space n;
                                        say "case ";
                                        sayv i;
                                        say "  ["; 
                                        say (int::to_string xvar);
                                        say "] of\n"; 
                                        g (0, nexts);
                                    };

                                ncf::FETCH_FROM_RAM { op, args, to_temp, type, next }
                                    =>
                                    {   space n;
                                        say (looker_name op);
                                        say "(";
                                        sayvlist args;
                                        say ") -> ";
                                        sayv (ncf::CODETEMP to_temp);
                                        sayt type;
                                        nl();
                                        f next;
                                    };

                                ncf::MATH { op, args, to_temp, type, next }
                                    =>
                                    {   space n;
                                        say (arith_name op);
                                        say "(";
                                        sayvlist args;
                                        say ") -> ";
                                        sayv (ncf::CODETEMP to_temp);
                                        sayt type;
                                        nl();
                                        f next;
                                    };

                                ncf::PURE { op, args, to_temp, type, next }
                                    =>
                                    {   space n;
                                        say (pure_name op);
                                        say "(";
                                        sayvlist args;
                                        say ") -> ";
                                        sayv (ncf::CODETEMP to_temp);
                                        sayt type;
                                        nl();
                                        f next;
                                    };

                                ncf::STORE_TO_RAM { op, args, next }
                                    =>
                                    {   space n;
                                        say (setter_name op);
                                        say "(";
                                        sayvlist args;
                                        say ")";
                                        nl();
                                        f next;
                                    };

                                ncf::IF_THEN_ELSE { op, args, xvar, then_next, else_next }
                                    =>
                                    {   space n;
                                        say "if ";
                                        say (branch_name op);
                                        say "("; sayvlist args;
                                        say ") ["; 
                                        sayv (ncf::CODETEMP xvar);
                                        say "] then\n";
                                        indent (n+3) then_next;
                                        space n; say "else\n";
                                        indent (n+3) else_next;
                                    };

                                ncf::RAW_C_CALL { kind, cfun_name, cfun_type, args, to_ttemps, next }
                                    =>
                                    {   space n; 
                                        #
                                        if   (kind == ncf::REENTRANT_RCC)   say "reentrant ";  fi;
                                        if   (cfun_name != "")  say cfun_name; say " ";  fi;

                                        say "rcc(";
                                        sayvlist args;
                                        say ") -> ";

                                        apply (fn (w, t) =  { sayv (ncf::CODETEMP w);   sayt t; })
                                              to_ttemps;

                                        nl();

                                        f next;
                                    };
                            end;
                    end;
             indent;
         };

        fun prettyprint_nextcode ((_, fun_id, arg_codetemps, arg_types, fun_body), m)                           # Ignored arg is 'fun_kind'.
            =
            {

                if *global_controls::compiler::debug_representation
                    #
                    fun ptv (v, t)
                        =
                        {   say (tmp::name_of_highcode_codetemp v);
                            say " type ===>>>";
                            say (hcf::uniqtype_to_string t);
                            say "\n";
                        };

                    say "************************************************\n";
                    iht::keyed_apply ptv m;
                    say "************************************************\n";
                fi;

                fun sayv  v
                    =
                    say (tmp::name_of_highcode_codetemp  v);

                sayt = say o ncf::cty_to_string;

                fun sayparam ([v],[ct]) => { sayv v;   sayt ct; };
                    sayparam (NIL, NIL) => ();
                    sayparam (v ! vl, ct ! cl) => { sayv v;   sayt ct;   say ", ";   sayparam (vl, cl); };
                    sayparam _ => error_message::impossible "sayparam in prettyprint-nextcode.pkg 3435";
                end;

                say (tmp::name_of_highcode_codetemp  fun_id);
                say "(";
                sayparam (arg_codetemps, arg_types);
                say ") =\n";  
                show0 say 3 fun_body;
            };


        exception NULLTABLE;


        my  nulltable:  iht::Hashtable( hut::Uniqtype )
            =
            iht::make_hashtable  { size_hint => 8,  not_found_exception => NULLTABLE };


        fun print_nextcode_expression  ce
            =
            show0 (global_controls::print::say)  1  ce;


        fun print_nextcode_function f
            =
            prettyprint_nextcode (f, nulltable);


        # This function takes MINUTES on mythryl.lex.pkg when called from
        # maybe_prettyprint_nextcode in src/lib/compiler/back/top/main/backend-tophalf-g.pkg
        # -- I think there must be an O(N**2) performance bug.  2010-09-08 CrT
        #
        fun prettyprint_nextcode_function  (pp: prettyprinter::Prettyprinter)  f
            =
            prettyprint_nextcode' (f, nulltable)
            where

                fun prettyprint_nextcode' ((_, f, vl, cl, e), m)
                    =
                    {
                        if *global_controls::compiler::debug_representation
                            #
                            fun ptv (v, t)
                                =
                                {   pp.put (tmp::name_of_highcode_codetemp v);
                                    pp.put " type ===>>>";
                                    pp.put (hcf::uniqtype_to_string t);
                                    pp.put "\n";
                                };

                            pp.put "************************************************\n";
                            iht::keyed_apply ptv m;
                            pp.put "************************************************\n";
                        fi;

                        say =  pp.put;

                        fun sayv v
                            =
                            pp.put (tmp::name_of_highcode_codetemp v);

                        sayt = say o ncf::cty_to_string;

                        fun sayparam ([v],[ct]) => { sayv v;   sayt ct; };
                            sayparam (NIL, NIL) => ();
                            sayparam (v ! vl, ct ! cl) => { sayv v;   sayt ct;   say ", ";   sayparam (vl, cl); };
                            sayparam _ => error_message::impossible "sayparam in prettyprint-nextcode.pkg 3435";
                        end;


                        {   pp.put (tmp::name_of_highcode_codetemp f);
                            pp.put "(";
                            sayparam (vl, cl);
                            pp.put ") =\n";  
                            show0 pp.put 3 e;
                        };
                    };
            end;


    };          #  package prettyprint_nextcode 
end;            #  toplevel stipulate 



Comments and suggestions to: bugs@mythryl.org

PreviousUpNext