mirror of
https://github.com/HDFGroup/hdf5.git
synced 2024-11-27 02:10:55 +08:00
a365f0e6aa
Bring r16305 back from revise_chunks branch: Add detection of C99 "designated initializers" to configure script and use new H5_HAVE_C99_DESIGNATED_INITIALIZER macro to conditionally compile default layout variables in src/H5Pdcpl.c Also, minor code cleanups, etc. Tested on: FreeBSD/32 6.3 (duty) in debug mode (Other platforms tested on branch)
320 lines
12 KiB
Perl
Executable File
320 lines
12 KiB
Perl
Executable File
#!/usr/bin/perl -w
|
|
##
|
|
# Copyright by The HDF Group.
|
|
# Copyright by the Board of Trustees of the University of Illinois.
|
|
# All rights reserved.
|
|
#
|
|
# This file is part of HDF5. The full HDF5 copyright notice, including
|
|
# terms governing use, modification, and redistribution, is contained in
|
|
# the files COPYING and Copyright.html. COPYING can be found at the root
|
|
# of the source code distribution tree; Copyright.html can be found at the
|
|
# root level of an installed copy of the electronic HDF5 document set and
|
|
# is linked from the top-level documents page. It can also be found at
|
|
# http://hdfgroup.org/HDF5/doc/Copyright.html. If you do not have
|
|
# access to either file, you may request a copy from help@hdfgroup.org.
|
|
##
|
|
require 5.003;
|
|
$Source = "";
|
|
|
|
##############################################################################
|
|
# A map from type name to type letter. We use this map for two reasons:
|
|
# 1. We want the debugging stuff in the source code to be as unobtrusive as
|
|
# possible, which means as compact as possible.
|
|
# 2. It's easier (faster) to parse these one and two-letter types in the C
|
|
# functions that display debugging results.
|
|
#
|
|
# All type strings are one or two characters. One-character strings
|
|
# are always lower case and should be used for common types.
|
|
# Two-character strings begin with an upper-case letter which is
|
|
# usually the same as the package name.
|
|
#
|
|
%TypeString = ("haddr_t" => "a",
|
|
"hbool_t" => "b",
|
|
"double" => "d",
|
|
"H5D_alloc_time_t" => "Da",
|
|
"H5FD_mpio_collective_opt_t" => "Dc",
|
|
"H5D_fill_time_t" => "Df",
|
|
"H5D_fill_value_t" => "DF",
|
|
"H5FD_mpio_chunk_opt_t" => "Dh",
|
|
"H5D_layout_t" => "Dl",
|
|
"H5D_space_status_t" => "Ds",
|
|
"H5FD_mpio_xfer_t" => "Dt",
|
|
"herr_t" => "e",
|
|
"H5E_direction_t" => "Ed",
|
|
"H5E_error_t" => "Ee",
|
|
"H5E_type_t" => "Et",
|
|
"H5F_close_degree_t" => "Fd",
|
|
"H5F_scope_t" => "Fs",
|
|
"H5F_libver_t" => "Fv",
|
|
"H5G_obj_t" => "Go",
|
|
"H5G_stat_t" => "Gs",
|
|
"hsize_t" => "h",
|
|
"hssize_t" => "Hs",
|
|
"H5E_major_t" => "i",
|
|
"H5E_minor_t" => "i",
|
|
"H5_iter_order_t" => "Io",
|
|
"H5_index_t" => "Ii",
|
|
"hid_t" => "i",
|
|
"int" => "Is",
|
|
"int32_t" => "Is",
|
|
"unsigned" => "Iu",
|
|
"unsigned int" => "Iu",
|
|
"H5I_type_t" => "It",
|
|
"H5G_link_t" => "Ll", #Same as H5L_type_t now
|
|
"H5L_type_t" => "Ll",
|
|
"MPI_Comm" => "Mc",
|
|
"MPI_Info" => "Mi",
|
|
"H5FD_mem_t" => "Mt",
|
|
"off_t" => "o",
|
|
"H5O_type_t" => "Ot",
|
|
"H5P_class_t" => "p",
|
|
"hobj_ref_t" => "r",
|
|
"H5R_type_t" => "Rt",
|
|
"char" => "s",
|
|
"H5S_class_t" => "Sc",
|
|
"H5S_seloper_t" => "Ss",
|
|
"H5S_sel_type" => "St",
|
|
"htri_t" => "t",
|
|
"H5T_cset_t", => "Tc",
|
|
"H5T_direction_t", => "Td",
|
|
"H5T_norm_t" => "Tn",
|
|
"H5T_order_t" => "To",
|
|
"H5T_pad_t" => "Tp",
|
|
"H5T_pers_t" => "Te",
|
|
"H5T_sign_t" => "Ts",
|
|
"H5T_class_t" => "Tt",
|
|
"H5T_str_t" => "Tz",
|
|
"void" => "x",
|
|
"FILE" => "x",
|
|
"H5A_operator_t" => "x",
|
|
"H5A_operator1_t" => "x",
|
|
"H5A_operator2_t" => "x",
|
|
"H5A_info_t" => "x",
|
|
"H5AC_cache_config_t" => "x",
|
|
"H5D_operator_t" => "x",
|
|
"H5E_auto_t" => "x",
|
|
"H5E_auto1_t" => "x",
|
|
"H5E_auto2_t" => "x",
|
|
"H5E_walk_t" => "x",
|
|
"H5E_walk1_t" => "x",
|
|
"H5E_walk2_t" => "x",
|
|
"H5F_info_t" => "x",
|
|
"H5FD_t" => "x",
|
|
"H5FD_class_t" => "x",
|
|
"H5FD_stream_fapl_t" => "x",
|
|
"H5G_iterate_t" => "x",
|
|
"H5G_info_t" => "x",
|
|
"H5I_free_t" => "x",
|
|
"H5L_class_t" => "x",
|
|
"H5L_elink_traverse_t" => "x",
|
|
"H5L_iterate_t" => "x",
|
|
"H5MM_allocate_t" => "x",
|
|
"H5MM_free_t" => "x",
|
|
"H5O_info_t" => "x",
|
|
"H5O_iterate_t" => "x",
|
|
"H5P_cls_create_func_t" => "x",
|
|
"H5P_cls_copy_func_t" => "x",
|
|
"H5P_cls_close_func_t" => "x",
|
|
"H5P_iterate_t" => "x",
|
|
"H5P_prp_create_func_t" => "x",
|
|
"H5P_prp_copy_func_t" => "x",
|
|
"H5P_prp_close_func_t" => "x",
|
|
"H5P_prp_delete_func_t" => "x",
|
|
"H5P_prp_get_func_t" => "x",
|
|
"H5P_prp_set_func_t" => "x",
|
|
"H5P_prp_compare_func_t" => "x",
|
|
"H5T_cdata_t" => "x",
|
|
"H5T_conv_t" => "x",
|
|
"H5T_conv_except_func_t" => "x",
|
|
"H5Z_func_t" => "x",
|
|
"H5Z_filter_func_t" => "x",
|
|
"size_t" => "z",
|
|
"H5Z_SO_scale_type_t" => "Za",
|
|
"H5Z_class_t" => "Zc",
|
|
"H5Z_EDC_t" => "Ze",
|
|
"H5Z_filter_t" => "Zf",
|
|
"ssize_t" => "Zs",
|
|
);
|
|
|
|
##############################################################################
|
|
# Print an error message.
|
|
#
|
|
sub errmesg ($$@) {
|
|
my ($file, $func, @mesg) = @_;
|
|
my ($mesg) = join "", @mesg;
|
|
my ($lineno) = 1;
|
|
if ($Source =~ /(.*?\n)($func)/s) {
|
|
local $_ = $1;
|
|
$lineno = tr/\n/\n/;
|
|
}
|
|
|
|
print "$file: in function \`$func\':\n";
|
|
print "$file:$lineno: $mesg\n";
|
|
}
|
|
|
|
##############################################################################
|
|
# Given a C data type return the type string that goes with it.
|
|
#
|
|
sub argstring ($$$) {
|
|
my ($file, $func, $atype) = @_;
|
|
my ($ptr, $tstr, $array) = (0, "!", "");
|
|
my ($fq_atype);
|
|
|
|
# Normalize the data type by removing redundant white space,
|
|
# certain type qualifiers, and indirection.
|
|
$atype =~ s/^\bconst\b//;
|
|
$atype =~ s/\bUNUSED\b//g;
|
|
$atype =~ s/\s+/ /g;
|
|
$ptr = length $1 if $atype =~ s/(\*+)//;
|
|
$atype =~ s/^\s+//;
|
|
$atype =~ s/\s+$//;
|
|
if ($atype =~ /(.*)\[(.*)\]$/) {
|
|
($array, $atype) = ($2, $1);
|
|
$atype =~ s/\s+$//;
|
|
}
|
|
$fq_atype = $atype . ('*' x $ptr);
|
|
|
|
if ($ptr>0 && exists $TypeString{$fq_atype}) {
|
|
$ptr = 0;
|
|
$tstr = $TypeString{$fq_atype};
|
|
} elsif ($ptr>0 && exists $TypeString{"$atype*"}) {
|
|
--$ptr;
|
|
$tstr = $TypeString{"$atype*"};
|
|
} elsif (!exists $TypeString{$atype}) {
|
|
errmesg $file, $func, "untraceable type \`$atype", '*'x$ptr, "\'";
|
|
} else {
|
|
$tstr = $TypeString{$atype};
|
|
}
|
|
return ("*" x $ptr) . ($array?"[$array]":"") . $tstr;
|
|
}
|
|
|
|
##############################################################################
|
|
# Given information about an API function, rewrite that function with
|
|
# updated tracing information.
|
|
#
|
|
sub rewrite_func ($$$$$) {
|
|
my ($file, $type, $name, $args, $body) = @_;
|
|
my ($arg,$trace);
|
|
my (@arg_name, @arg_str);
|
|
local $_;
|
|
|
|
# Parse return value
|
|
my $rettype = argstring $file, $name, $type;
|
|
goto error if $rettype =~ /!/;
|
|
|
|
# Parse arguments
|
|
if ($args eq "void") {
|
|
$trace = "H5TRACE0(\"$rettype\",\"\");\n";
|
|
} else {
|
|
# Split arguments. First convert `/*in,out*/' to get rid of the
|
|
# comma, then split the arguments on commas.
|
|
$args =~ s/(\/\*\s*in),\s*(out\s*\*\/)/$1_$2/g;
|
|
my @args = split /,[\s\n]*/, $args;
|
|
my $argno = 0;
|
|
my %names;
|
|
|
|
for $arg (@args) {
|
|
unless ($arg=~/^(([a-z_A-Z]\w*\s+)+\**)
|
|
([a-z_A-Z]\w*)(\[.*?\])?
|
|
(\s*\/\*\s*(in|out|in_out)\s*\*\/)?\s*$/x) {
|
|
errmesg $file, $name, "unable to parse \`$arg\'";
|
|
goto error;
|
|
} else {
|
|
my ($atype, $aname, $array, $adir) = ($1, $3, $4, $6);
|
|
$names{$aname} = $argno++;
|
|
$adir ||= "in";
|
|
$atype =~ s/\s+$//;
|
|
push @arg_name, $aname;
|
|
|
|
if ($adir eq "out") {
|
|
push @arg_str, "x";
|
|
} else {
|
|
if (defined $array) {
|
|
$atype .= "*";
|
|
if ($array =~ /^\[\/\*([a-z_A-Z]\w*)\*\/\]$/) {
|
|
my $asize = $1;
|
|
if (exists $names{$asize}) {
|
|
$atype .= '[a' . $names{$asize} . ']';
|
|
} else {
|
|
warn "bad array size: $asize";
|
|
$atype .= "*";
|
|
}
|
|
}
|
|
}
|
|
push @arg_str, argstring $file, $name, $atype;
|
|
}
|
|
}
|
|
}
|
|
$trace = "H5TRACE" . scalar(@arg_str) . "(\"$rettype\", \"";
|
|
$trace .= join("", @arg_str) . "\"";
|
|
my $len = 4 + length $trace;
|
|
for (@arg_name) {
|
|
if ($len + length >= 77) {
|
|
$trace .= ",\n $_";
|
|
$len = 13 + length;
|
|
} else {
|
|
$trace .= ", $_";
|
|
$len += 1 + length;
|
|
}
|
|
}
|
|
$trace .= ");\n";
|
|
}
|
|
goto error if grep {/!/} @arg_str;
|
|
|
|
# The H5TRACE() statement
|
|
if ($body =~ /\/\*[ \t]*NO[ \t]*TRACE[ \t]*\*\//) {
|
|
if ($body =~ /\s*H5TRACE\d+\s*\(/) {
|
|
errmesg $file, $name, "warning: trace info was not updated because of NO TRACE comment";
|
|
} else {
|
|
errmesg $file, $name, "warning: trace info was not inserted because of NO TRACE comment";
|
|
}
|
|
} elsif ($body =~ s/((\n[ \t]*)H5TRACE\d+\s*\(.*?\);)\n/"$2$trace"/es) {
|
|
# Replaced an H5TRACE macro
|
|
} elsif ($body=~s/((\n[ \t]*)FUNC_ENTER\w*\s*\(.*?\);??)\n/"$1$2$trace"/es) {
|
|
# Added an H5TRACE macro after a FUNC_ENTER macro.
|
|
} else {
|
|
errmesg $file, $name, "unable to insert tracing information";
|
|
print "body = ", $body, "\n";
|
|
goto error;
|
|
}
|
|
|
|
|
|
error:
|
|
return "\n$type\n$name($args)\n$body";
|
|
}
|
|
|
|
##############################################################################
|
|
# Process each source file, rewriting API functions with updated
|
|
# tracing information.
|
|
#
|
|
my $total_api = 0;
|
|
for $file (@ARGV) {
|
|
# Ignore some files that do not need tracing macros
|
|
unless ($file eq "H5FDmulti.c" or $file eq "src/H5FDmulti.c" or $file eq "H5FDstdio.c" or $file eq "src/H5FDstdio.c") {
|
|
|
|
# Snarf up the entire file
|
|
open SOURCE, $file or die "$file: $!\n";
|
|
$Source = join "", <SOURCE>;
|
|
close SOURCE;
|
|
|
|
# Make modifications
|
|
my $original = $Source;
|
|
my $napi = $Source =~ s/\n([A-Za-z]\w*(\s+[a-z]\w*)*)\s*\n #type
|
|
(H5[A-Z]{0,2}[^_A-Z0-9]\w*) #name
|
|
\s*\((.*?)\)\s* #args
|
|
(\{.*?\n\}[^\n]*) #body
|
|
/rewrite_func($file,$1,$3,$4,$5)/segx;
|
|
$total_api += $napi;
|
|
|
|
# If the source changed then print out the new version
|
|
if ($original ne $Source) {
|
|
printf "%s: instrumented %d API function%s\n",
|
|
$file, $napi, 1==$napi?"":"s";
|
|
rename $file, "$file~" or die "unable to make backup";
|
|
open SOURCE, ">$file" or die "unable to modify source";
|
|
print SOURCE $Source;
|
|
close SOURCE;
|
|
}
|
|
}
|
|
}
|