## prettyprint-nextcode.pkg
# Compiled by:
# src/lib/compiler/core.sublibstipulate
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 ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkgherein
api Prettyprint_Nextcode {
#
prettyprint_nextcode # This entrypoint is not currently called from outside this file.
:
(ncf::Function, iht::Hashtable( hut::Uniqtypoid) )
->
Void;
print_nextcode_expression: ncf::Instruction -> Void;
print_nextcode_function: ncf::Function -> Void;
prettyprint_nextcode_function
:
pp::Prettyprinter
->
ncf::Function
->
Void;
};
end;
stipulate
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 ncf = nextcode_form; # nextcode_form is from src/lib/compiler/back/top/nextcode/nextcode-form.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkgherein
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 { kind_and_size } ) => ("numsubscript" + numkind_name kind_and_size);
looker_name ncf::p::GET_RUNTIME_ASM_PACKAGE_RECORD => "getrunvec";
looker_name ncf::p::GET_CURRENT_MICROTHREAD_REGISTER => "get_current_microthread_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 { kind_and_size } ) => ("rawload" + numkind_name kind_and_size);
end;
fun branch_name ncf::p::IS_BOXED => "boxed";
branch_name ncf::p::IS_UNBOXED => "unboxed";
branch_name (ncf::p::COMPARE { op, kind_and_size } )
=>
numkind_name kind_and_size
+
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::RW_VECTOR_SET => "set_vecslot";
setter_name (ncf::p::SET_VECSLOT_TO_NUMERIC_VALUE { kind_and_size } ) => ("set_vecslot_to_numeric_value" + numkind_name kind_and_size);
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_MICROTHREAD_REGISTER => "set_current_microthread_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 { kind_and_size } ) => ("set_raw_ram" + numkind_name kind_and_size);
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::ARITH { op, kind_and_size } )
=>
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 kind_and_size;
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::ARITH 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::RO_VECTOR_GET => "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::RECORD_GET => "get_recslot_contents";
pure_name ncf::p::RAW64_GET => "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 { kind_and_size } )
=>
("numsubscriptv" + numkind_name kind_and_size);
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::FATE_FN => "ncf::rk::FATE_FN";
ncf::rk::FLOAT64_FATE_FN => "ncf::rk::FLOAT64_FATE_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
=
\\ 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 { fn, args }
=>
{ space n;
sayv fn;
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::ARITH { 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 (\\ (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::uniqtypoid_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::Uniqtypoid )
=
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: standard_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.txt (tmp::name_of_highcode_codetemp v);
pp.txt " type ===>>>";
pp.txt (hcf::uniqtypoid_to_string t);
pp.txt "\n";
};
pp.txt "************************************************\n";
iht::keyed_apply ptv m;
pp.txt "************************************************\n";
fi;
say = pp.txt;
fun sayv v
=
pp.txt (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.txt (tmp::name_of_highcode_codetemp f);
pp.txt "(";
sayparam (vl, cl);
pp.txt ") =\n";
show0 (pp.txt) 3 e;
};
};
end;
}; # package prettyprint_nextcode
end; # toplevel stipulate