## add-per-fun-byte-counters-to-deep-syntax.pkg
#
# 2011-07-08 CrT: The general idea here seems to be to establish
# a hook at the start of every function which can be used to call
# arbitrary profiling code.
#
# In slightly more detail, the rough idea seems to be to call 'enter'
# once for each FN_IN_EXPRESSION with 3 args:
# arg1 is source code location;
# arg2 accumulates list of all functions we've tweaked this way;
# arg3 is the body of the fn
# and then wrap body 'expression' n to be enterexp(expression,n)
#
# The rest of the code in this file appears to just be doing a dagwalk
# to find all FN_IN_EXPRESSION nodes and call 'enter' on them.
#
# Apparently "sprof" == "space profiling" and "tprof" == "time profiling".
#
# add-per-fun-call-counters-to-deep-syntax.pkgappears to contain similar logic -- but working. :-)
#
# See also:
#
# src/lib/compiler/debugging-and-profiling/profiling/add-per-fun-call-counters-to-deep-syntax.pkg# src/lib/compiler/debugging-and-profiling/profiling/tdp-instrument.pkg# src/lib/compiler/back/top/closures/allocprof.pkg# Compiled by:
# src/lib/compiler/debugging-and-profiling/debugprof.sublibstipulate
package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg package pcs = per_compile_stuff; # per_compile_stuff is from src/lib/compiler/front/typer-stuff/main/per-compile-stuff.pkg package sci = sourcecode_info; # sourcecode_info is from src/lib/compiler/front/basics/source/sourcecode-info.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkgherein
api Add_Per_Fun_Byte_Counters_To_Deep_Syntax {
#
maybe_add_per_fun_byte_counters_to_deep_syntax
:
( syx::Symbolmapstack,
pcs::Per_Compile_Stuff( ds::Declaration )
)
-> sci::Sourcecode_Info
-> ds::Declaration
-> ds::Declaration;
};
end;
### "The honest truth is that having
### a lot of people staring at the code
### does not find the really nasty bugs.
### The really nasty bugs are found
### by a couple of really smart people
### who just kill themselves."
###
### -- Bill Joy
stipulate
package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg package pcs = per_compile_stuff; # per_compile_stuff is from src/lib/compiler/front/typer-stuff/main/per-compile-stuff.pkgherein
package add_per_fun_byte_counters_to_deep_syntax
: Add_Per_Fun_Byte_Counters_To_Deep_Syntax # Add_Per_Fun_Byte_Counters_To_Deep_Syntax is from src/lib/compiler/debugging-and-profiling/profiling/add-per-fun-byte-counters-to-deep-syntax.pkg {
# WARNING: THE MAIN CODE IS CURRENTLY TURNED OFF;
# we will merge in Chesakov's SProf in the future (ZHONG).
# This fun is called (only) from maybe_instrument_deep_syntax in
#
# src/lib/compiler/toplevel/main/translate-raw-syntax-to-execode-g.pkg #
fun maybe_add_per_fun_byte_counters_to_deep_syntax
#
( dictionary,
per_compile_stuff as { issue_highcode_codetemp, ... }: pcs::Per_Compile_Stuff( ds::Declaration )
)
source deep_syntax_tree
=
deep_syntax_tree;
};
end;
/*
package {
local package sp = symbol_path
package v = variables_and_constructors
package m = module
package b = Namings
package hbo = highcode_baseops
use deep_syntax variables_and_constructors types more_type_types
in
infix -->
xsym = symbol::make_value_symbol "x"
fun maybe_add_per_fun_byte_counters_to_deep_syntax dictionary source deep_syntax_tree
=
if not *runtime_internals::rpc::sprofiling # runtime_internals is from src/lib/std/src/nj/runtime-internals.pkg then deep_syntax_tree
else let
my namelist: Ref( List( String ) ) = REF NIL
namecount = REF 0
alpha = TYPESCHEME_ARG 0
my entervar as PLAIN_VARIABLE { type=entertype, ... } =
make_ordinary_variable (symbol::make_value_symbol "enter", HIGHCODE_VARIABLE (issue_highcode_codetemp()))
entertype := TYPESCHEME_TYPE { sign=[FALSE],
typescheme = TYPESCHEME { arity=1,
body=tupleType[alpha, intType] --> alpha }}
enterexp = VARIABLE_IN_EXPRESSION (REF entervar, [])
fun clean names = names
err = error_message::impossible
#
#
#
fun enter((line_a, line_b), names, expression) =
let fun dot (a,[z]) = symbol::name z . a
| dot (a, x . rest) = dot("." . symbol::name x . a, rest)
| dot _ = err "no path in instrexp"
my (fname, lineno_a, charpos_a) = sourcecode_info::filepos source line_a
my (_, lineno_b, charpos_b) = sourcecode_info::filepos source line_b
position = [fname, ":", int::to_string lineno_a, ".",
int::to_string charpos_a, "-", int::to_string lineno_b, ".",
int::to_string charpos_b, ":"]
name = cat (position @ dot (["\n"], names))
index = *namecount
in namecount := index + 1;
namelist := name . *namelist;
APPLY_EXPRESSION (enterexp,
typer_junk::TUPLE_IN_EXPRESSION [expression, INT_CONSTANT_IN_EXPRESSION (int::to_string index, intType)])
end
fun instrdec (line, names, VALUE_DECLARATIONS vbl)
=
{ fun instrvb (valueNaming as NAMED_VALUE { pattern=VARIABLE_IN_PATTERN (PLAIN_VARIABLE { access=PRIMOP _, ... } ), ... } ) =valueNaming
| instrvb (valueNaming as NAMED_VALUE { pattern=TYPE_CONSTRAINT_PATTERN
(VARIABLE_IN_PATTERN (PLAIN_VARIABLE { access=PRIMOP _, ... } ), _), ... } ) = valueNaming
| instrvb (NAMED_VALUE { pattern as VARIABLE_IN_PATTERN (PLAIN_VARIABLE { path=sp::SYMBOL_PATH[n], ... } ),
expression, typevars, generalized_typevars } ) =
NAMED_VALUE { pattern=pattern,
expression=instrexp (line, n . clean names) expression,
typevars=typevars, generalized_typevars=bound_typevar_refs }
| instrvb (NAMED_VALUE { pattern as TYPE_CONSTRAINT_PATTERN (VARIABLE_IN_PATTERN (PLAIN_VARIABLE { path=sp::SYMBOL_PATH[n], ... } ), _),
expression, typevars, generalized_typevars } ) =
NAMED_VALUE { pattern=pattern,
expression=instrexp (line, n . clean names) expression,
typevars=typevars, generalized_typevars=bound_typevar_refs }
| instrvb (NAMED_VALUE { pattern, expression, typevars, generalized_typevars } ) =
NAMED_VALUE { pattern=pattern, expression=instrexp (line, names) expression, typevars=typevars,
generalized_typevars=bound_typevar_refs };
VALUE_DECLARATIONS (map instrvb vbl);
}
| instrdec (line, names, RECURSIVE_VALUE_DECLARATIONS rvbl)
=
{ fun instrrvb (NAMED_RECURSIVE_VALUE { var as PLAIN_VARIABLE { path=sp::SYMBOL_PATH[n], ... },
expression, result_type, raw_typevars, generalized_typevars } ) =
NAMED_RECURSIVE_VALUE { var=var,
expression=instrexp (line, n . clean names) expression,
result_type=result_type, raw_typevars, generalized_typevars=bound_typevar_refs }
| instrrvb _ = err "RECURSIVE_VALUE_DECLARATIONS in SProf::instrdec";
RECURSIVE_VALUE_DECLARATIONS (map instrrvb rvbl);
}
| instrdec (line, names, ABSTRACT_TYPE_DECLARATION { abstract_types, with_types, body } )
=
ABSTRACT_TYPE_DECLARATION { abstract_types=abstractTypeConstructors, with_types=withTypeConstructors,
body=instrdec (line, names, body) };
| instrdec (line, names, PACKAGE_DECLARATION strbl)
=
PACKAGE_DECLARATION (map (\\ named_package => instrstrb (line, names, named_package)) strbl)
| instrdec (line, names, ABSTRACT_PACKAGE_DECLARATIONS strbl) =
ABSTRACT_PACKAGE_DECLARATIONS (map (\\ named_package => instrstrb (line, names, named_package)) strbl)
| instrdec (line, names, GENERIC_DECLARATION fctable) =
GENERIC_DECLARATION (map (\\ generic_naming => instrfctb (line, names, generic_naming)) fctable)
| instrdec (line, names, LOCAL_DECLARATION (localdec, visibledec)) =
LOCAL_DECLARATION (instrdec (line, names, localdec),
instrdec (line, names, visibledec))
| instrdec (line, names, SEQUENTIAL_DECLARATIONS decl) =
SEQUENTIAL_DECLARATIONS (map (\\ declaration => instrdec (line, names, declaration)) decl)
| instrdec (line, names, SOURCE_CODE_REGION_FOR_DECLARATION (declaration, source_code_region)) =
SOURCE_CODE_REGION_FOR_DECLARATION (instrdec (source_code_region, names, declaration), source_code_region)
| instrdec (line, names, other) = other
and /* instrstrexp (line, names, STRUCTstr { body, locations, str } ) =
STRUCTstr { body = (map (\\ declaration => instrdec (line, names, declaration)) body),
locations=locations, str=str }
| */ instrstrexp (line, names, COMPUTED_PACKAGE { op, arg, parameterTypes, result, restypes } ) =
COMPUTED_PACKAGE { op=oper, arg=instrstrexp (line, names, arg),
parameterTypes=parameterTypes, result=result, restypes=restypes }
| instrstrexp (line, names, VARIABLE_PACKAGE x) = VARIABLE_PACKAGE x
| instrstrexp (line, names, PACKAGE_LET { declaration => d, expression => body })
=
PACKAGE_LET { declaration => instrdec (line, names, d), expression => instrstrexp (line, names, body)}
| instrstrexp (line, names, SOURCE_CODE_REGION_FOR_PACKAGE (body, source_code_region))
=
SOURCE_CODE_REGION_FOR_PACKAGE (instrstrexp (source_code_region, names, body), source_code_region)
and instrstrb (line, names, NAMED_PACKAGE { name, str, def } ) =
NAMED_PACKAGE { str=str, def=instrstrexp (line, name . names, def), name=name }
and instrfctb (line, names,
NAMED_GENERIC { fct, name, def=GENERIC_DEFINITION { parameter, def=d, parameterTypes,
fct=f, restypes }} ) =
NAMED_GENERIC { fct=fct, name=name,
def=GENERIC_DEFINITION { parameter=parameter, def=instrstrexp (line, name . names, d),
fct=f, restypes=restypes, parameterTypes=parameterTypes }}
| instrfctb (line, names, generic_naming) = generic_naming
and instrexp (line, names) =
let fun rule (RULE (p, e)) = RULE (p, iexp e)
and iexp (RECORD_IN_EXPRESSION (l as _ . _)) =
let fun field (lab, expression) = (lab, iexp expression)
in enter (line, symbol::make_value_symbol (int::to_string (length l)) . names,
RECORD_IN_EXPRESSION (map field l))
end
| iexp (VECTOR_IN_EXPRESSION (l, t)) = VECTOR_IN_EXPRESSION((map iexp l), t)
| iexp (SEQUENTIAL_EXPRESSIONS l) = SEQUENTIAL_EXPRESSIONS (map iexp l)
| iexp (APPLY_EXPRESSION (f, a)) = APPLY_EXPRESSION (iexp f, iexp a)
| iexp (TYPE_CONSTRAINT_EXPRESSION (e, t)) = TYPE_CONSTRAINT_EXPRESSION (iexp e, t)
| iexp (EXCEPT_EXPRESSION (e, HANDLER (FN_EXPRESSION (l, t)))) =
EXCEPT_EXPRESSION (iexp e, HANDLER (FN_EXPRESSION (map rule l, t)))
| iexp (EXCEPT_EXPRESSION (e, HANDLER h)) = EXCEPT_EXPRESSION (iexp e, HANDLER (iexp h))
| iexp (RAISE_EXPRESSION (e, t)) = RAISE_EXPRESSION (iexp e, t)
| iexp (LET_EXPRESSION (d, e)) = LET_EXPRESSION (instrdec (line, names, d), iexp e)
| iexp (CASE_EXPRESSION (e, l, b)) = CASE_EXPRESSION (iexp e, map rule l, b)
| iexp (FN_EXPRESSION (l, t)) = enter (line, names, (FN_EXPRESSION (map rule l, t)))
| iexp (SOURCE_CODE_REGION_FOR_EXPRESSION (e, source_code_region)) = SOURCE_CODE_REGION_FOR_EXPRESSION (instrexp (source_code_region, names) e, source_code_region)
| iexp (e as VALCON_IN_EXPRESSION { valcon => VALCON { form, ... }, ... }) =
(case form
of (UNTAGGED | TAGGED _ | REF | EXNFUN _) => # ZHONG?
etaexpand e
| _ => e)
| iexp e = e
and etaexpand (e as VALCON_IN_EXPRESSION { typescheme_args => t, ... }) =
let v = PLAIN_VARIABLE { access=HIGHCODE_VARIABLE (issue_highcode_codetemp()),
path=sp::SYMBOL_PATH [xsym],
type=REF types::UNDEFINED_TYPE }
in FN_EXPRESSION([RULE (VARIABLE_IN_PATTERN v,
enter (line, names, APPLY_EXPRESSION (e, VARIABLE_IN_EXPRESSION (REF v, []))))],
types::UNDEFINED_TYPE)
end
| etaexpand _ = err "etaexpand in add-per-fun-byte-counters-to-deep-syntax.pkg"
in iexp
end
derefop = PLAIN_VARIABLE { path = sp::SYMBOL_PATH [symbol::make_value_symbol "!"],
access = PRIMOP hbo::GET_REFCELL_CONTENTS,
type = REF (TYPESCHEME_TYPE { sign=[FALSE],
typescheme = TYPESCHEME { arity=1,
body=
TYPCON_TYPE (refType,[alpha])
--> alpha }} ) }
registerType =
TYPESCHEME_TYPE { sign=[FALSE],
typescheme = TYPESCHEME { arity=1,
body= TYPCON_TYPE (refType,[stringType -->
(tupleType[alpha, intType]
--> alpha)]) }}
registerVariable = core_access::getVariable "space_profiling_register"
deep_syntax_tree' =instrdec((0, 0), NIL, deep_syntax_tree)
in
LOCAL_DECLARATION (
VALUE_DECLARATIONS [
NAMED_VALUE {
pattern = VARIABLE_IN_PATTERN entervar,
expression = APPLY_EXPRESSION (
APPLY_EXPRESSION (
VARIABLE_IN_EXPRESSION (REF derefop,[]),
VARIABLE_IN_EXPRESSION (REF (registerVariable),[])
),
STRING_CONSTANT_IN_EXPRESSION (cat (reverse *namelist))
),
typevars = REF NIL,
generalized_typevars = []
}
], # ZHONG?
deep_syntax_tree'
)
end # function instrumentDeclaration
end # local
} # package add_per_fun_byte_counters_to_deep_syntax
*/