diff options
Diffstat (limited to 'erts/emulator/utils/make_alloc_types')
-rwxr-xr-x | erts/emulator/utils/make_alloc_types | 672 |
1 files changed, 672 insertions, 0 deletions
diff --git a/erts/emulator/utils/make_alloc_types b/erts/emulator/utils/make_alloc_types new file mode 100755 index 0000000000..53051b7692 --- /dev/null +++ b/erts/emulator/utils/make_alloc_types @@ -0,0 +1,672 @@ +#!/usr/bin/env perl +# -*- cperl -*- + +# %CopyrightBegin% +# +# Copyright Ericsson AB 2003-2009. All Rights Reserved. +# +# The contents of this file are subject to the Erlang Public License, +# Version 1.1, (the "License"); you may not use this file except in +# compliance with the License. You should have received a copy of the +# Erlang Public License along with this software. If not, it can be +# retrieved online at http://www.erlang.org/. +# +# Software distributed under the License is distributed on an "AS IS" +# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +# the License for the specific language governing rights and limitations +# under the License. +# +# %CopyrightEnd% + +use strict; +# use warnings; + +use File::Basename; + +# +# Description: +# Generates a header file containing defines for memory allocation types +# from type declarations in a config file. +# +# Usage: +# make_alloc_types -src <config-file> -dst <c-header-file> +# +# Options: +# -src <config-file> +# -dst <c-header-file> +# [<enabled-boolean-variable> ...] +# +# Author: Rickard Green +# + +my $myname = basename($0); +my $src; +my $dst; +my %bool_vars; + +while (@ARGV && $ARGV[0]) { + my $opt = shift; + if ($opt eq '-src') { + $src = shift; + $src or die "$myname: Missing source file\n"; + } elsif ($opt eq '-dst') { + $dst = shift; + $dst or die "$myname: Missing destination file\n"; + } else { + $bool_vars{$opt} = 'true'; + } +} + +$src or usage("Missing source file"); +$dst or usage("Missing destination file"); + +open(SRC, "<$src") or die "$myname: Failed to open $src in read mode\n"; + +my $line; +my $line_no = 0; +my $decl; + +my %a_tab; +my %c_tab; +my %t_tab; +my %d_tab; +my @a_order; +my @c_order; +my @t_order; + +my @cond_stack; + +############################################################################# +# Parse source file +############################################################################# + +while ($line = <SRC>) { + $line_no = $line_no + 1; + $line = preprocess_line($line); + + if ($line =~ /^(\S+)\s*(.*)/) { + $decl = $1; + $line = $2; + + if ($decl eq 'type') { + if ($line =~ /^(\w+)\s+(\w+)\s+(\w+)\s+(\w+)\s*$/) { + my $t = $1; + my $a = $2; + my $c = $3; + my $d = $4; + + check_reserved_words('type', $t, $d); + + my $a_entry = $a_tab{$a}; + $a_entry or src_error("No allocator '$a' declared"); + my $c_entry = $c_tab{$c}; + $c_entry or src_error("No class '$c' declared"); + + !$t_tab{$t} or src_error("Type '$t' already declared"); + my $d_user = $d_tab{$d}; + !$d_user or duplicate_descr($d, $d_user); + + $t_tab{$t} = mk_entry($d, $a, $c); + add_type($a_entry, $t); + + $d_tab{$d} = "type '$t'"; + + } else { + invalid_decl($decl); + } + } elsif ($decl eq 'allocator') { + if ($line =~ /^(\w+)\s+(\w+)\s+(\w+)\s*$/) { + my $a = $1; + my $mt = $2; + my $d = $3; + + check_reserved_words('allocator', $a, $d); + + !$a_tab{$a} or src_error("Allocator '$a' already declared"); + my $d_user = $d_tab{$d}; + !$d_user or duplicate_descr($d, $d_user); + + my $e = mk_entry($d); + $a_tab{$a} = $e; + + if ($mt =~ /^true$/) { + set_multi_thread($e); + } + else { + $mt =~ /^false$/ or src_error("Multi-thread option not a boolean"); + } + + $d_tab{$d} = "allocator '$a'"; + + push(@a_order, $a); + + } else { + invalid_decl($decl); + } + } elsif ($decl eq 'class') { + if ($line =~ /^(\w+)\s+(\w+)\s*$/) { + my $c = $1; + my $d = $2; + + check_reserved_words('class', $c, $d); + + !$c_tab{$c} or src_error("Class '$c' already declared"); + my $d_user = $d_tab{$d}; + !$d_user or duplicate_descr($d, $d_user); + + $c_tab{$c} = mk_entry($d); + + $d_tab{$d} = "class '$c'"; + + } else { + invalid_decl($decl); + } + } else { + src_error("Unknown '$decl' declaration found"); + } + } +} + +close(SRC) or warn "$myname: Error closing $src"; + +check_cond_stack(); + +############################################################################# +# Create destination file +############################################################################# + +mkdir(dirname($dst), 0777); +open(DST, ">$dst") or die "$myname: Failed to open $dst in write mode\n"; + +print DST "/* + * ----------------------------------------------------------------------- + * + * NOTE: Do *not* edit this file; instead, edit '", basename($src),"' and + * build again! This file was automatically generated by + * '$myname' on ", (scalar localtime), ". + * + * ----------------------------------------------------------------------- + * + * + * Copyright Ericsson AB ", (1900 + (localtime)[5]), ". All Rights Reserved. + * + * The contents of this file are subject to the Erlang Public License, + * Version 1.1, (the \"License\"); you may not use this file except in + * compliance with the License. You should have received a copy of the + * Erlang Public License along with this software. If not, it can be + * retrieved online at http://www.erlang.org/. + * + * Software distributed under the License is distributed on an \"AS IS\" + * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See + * the License for the specific language governing rights and limitations + * under the License. + * + */ + +#ifndef ERL_ALLOC_TYPES_H__ +#define ERL_ALLOC_TYPES_H__ + +"; + +my $a_no = 1; +my $c_no = 1; +my $t_no = 1; + +# Print allocator numbers ------------------------------------------------- + +print DST " +/* --- Allocator numbers -------------------------------------------------- */ + +#define ERTS_ALC_A_INVALID (0) + +"; + +print DST "#define ERTS_ALC_A_MIN ($a_no)\n\n"; + +foreach my $a (@a_order) { + set_number($a_tab{$a}, $a_no); + print DST "#define ERTS_ALC_A_$a ($a_no)\n"; + $a_no++; +} +$a_no--; + +print DST "\n#define ERTS_ALC_A_MAX ($a_no)\n"; + +# Print class numbers ----------------------------------------------------- + +print DST " + +/* --- Class numbers ------------------------------------------------------ */ + +#define ERTS_ALC_C_INVALID (0) + +"; + +print DST "#define ERTS_ALC_C_MIN ($c_no)\n\n"; + +foreach my $c (keys(%c_tab)) { + push(@c_order, $c); + set_number($c_tab{$c}, $c_no); + print DST "#define ERTS_ALC_C_$c ($c_no)\n"; + $c_no++; +} +$c_no--; +print DST "\n#define ERTS_ALC_C_MAX ($c_no)\n"; + +# Print type number intervals --------------------------------------------- + +print DST " + +/* --- Type number intervals ---------------------------------------------- */ + +#define ERTS_ALC_N_INVALID (0) + +"; + +print DST "#define ERTS_ALC_N_MIN ($t_no)\n\n"; + +foreach my $a (@a_order) { + my $a_entry = $a_tab{$a}; + my $ts = get_types($a_entry); + my $n_ts = @{$ts}; + if ($n_ts > 0) { + + print DST "/* Type numbers used for ", get_description($a_entry), " */\n"; + print DST "#define ERTS_ALC_N_MIN_A_$a ($t_no)\n"; + + foreach my $t (@{$ts}) { + push(@t_order, $t); + set_number($t_tab{$t}, $t_no); +# print DST "#define ERTS_ALC_N_$t ($t_no)\n"; + $t_no++; + } + + print DST "#define ERTS_ALC_N_MAX_A_$a (", $t_no - 1, ")\n\n"; + } + else { + print DST "/* No types use ", get_description($a_entry), " */\n\n"; + } +} +$t_no--; +print DST "#define ERTS_ALC_N_MAX ($t_no)\n"; + +# Print multi thread use of allocators ------------------------------------- + +print DST " + +/* --- Multi thread use of allocators -------------------------------------- */ + +"; + +foreach my $a (@a_order) { + my $mt = get_multi_thread($a_tab{$a}); + print DST "#define ERTS_ALC_MTA_$a (", $mt ? "1" : "0" ,")\n"; +} + + +# Calculate field sizes, masks, and shifts needed -------------------------- + +my $a_bits = fits_in_bits($a_no); +my $c_bits = fits_in_bits($c_no); +my $n_bits = fits_in_bits($t_no); +my $t_bits = $a_bits + $n_bits + $c_bits; + +$n_bits <= 16 + # Memory trace format expects type numbers to fit into an Uint16 + or die("$myname: ", $t_no + 1, " types declared;", + " maximum number of types allowed are ", (1 << 16),"\n"); + +$t_bits <= 24 + # We want 8 bits for flags (we actually only use 1 bit for flags + # at the time of writing)... + or die("$myname: More allocators, classes, and types declared than ", + "allowed\n"); + +my $a_mask = (1 << $a_bits) - 1; +my $c_mask = (1 << $c_bits) - 1; +my $n_mask = (1 << $n_bits) - 1; +my $t_mask = (1 << $t_bits) - 1; + +my $a_shift = 0; +my $c_shift = $a_bits + $a_shift; +my $n_shift = $c_bits + $c_shift; + + +# Print the types ---------------------------------------------------------- + +print DST " + +/* --- Types --------------------------------------------------------------- */ + +typedef Uint32 ErtsAlcType_t; /* The type used for memory types */ + +#define ERTS_ALC_T_INVALID (0) + +"; + +foreach my $t (@t_order) { + print DST + "#define ERTS_ALC_T_$t (", + ((get_number($a_tab{get_allocator($t_tab{$t})}) << $a_shift) + | (get_number($c_tab{get_class($t_tab{$t})}) << $c_shift) + | (get_number($t_tab{$t}) << $n_shift)), + ")\n"; +} + + + +# Print field sizes, masks, and shifts needed ------------------------------ + +print DST " + +/* --- Field sizes, masks, and shifts -------------------------------------- */ + +#define ERTS_ALC_A_BITS ($a_bits) +#define ERTS_ALC_C_BITS ($c_bits) +#define ERTS_ALC_N_BITS ($n_bits) +#define ERTS_ALC_T_BITS ($t_bits) + +#define ERTS_ALC_A_MASK ($a_mask) +#define ERTS_ALC_C_MASK ($c_mask) +#define ERTS_ALC_N_MASK ($n_mask) +#define ERTS_ALC_T_MASK ($t_mask) + +#define ERTS_ALC_A_SHIFT ($a_shift) +#define ERTS_ALC_C_SHIFT ($c_shift) +#define ERTS_ALC_N_SHIFT ($n_shift) +"; + +# Print mappings needed ---------------------------------------------------- + +print DST " + +/* --- Mappings ------------------------------------------------------------ */ + +/* type -> type number */ +#define ERTS_ALC_T2N(T) (((T) >> ERTS_ALC_N_SHIFT) & ERTS_ALC_N_MASK) + +/* type -> allocator number */ +#define ERTS_ALC_T2A(T) (((T) >> ERTS_ALC_A_SHIFT) & ERTS_ALC_A_MASK) + +/* type -> class number */ +#define ERTS_ALC_T2C(T) (((T) >> ERTS_ALC_C_SHIFT) & ERTS_ALC_C_MASK) + +/* type number -> type */ +#define ERTS_ALC_N2T(N) (erts_alc_n2t[(N)]) + +/* type number -> type description */ +#define ERTS_ALC_N2TD(N) (erts_alc_n2td[(N)]) + +/* type -> type description */ +#define ERTS_ALC_T2TD(T) (ERTS_ALC_N2TD(ERTS_ALC_T2N((T)))) + +/* class number -> class description */ +#define ERTS_ALC_C2CD(C) (erts_alc_c2cd[(C)]) + +/* allocator number -> allocator description */ +#define ERTS_ALC_A2AD(A) (erts_alc_a2ad[(A)]) + +extern const ErtsAlcType_t erts_alc_n2t[]; +extern const char *erts_alc_n2td[]; +extern const char *erts_alc_c2cd[]; +extern const char *erts_alc_a2ad[]; + +#ifdef ERTS_ALC_INTERNAL__ + +const ErtsAlcType_t erts_alc_n2t[] = { + ERTS_ALC_T_INVALID, +"; + +foreach my $t (@t_order) { + print DST " ERTS_ALC_T_$t,\n"; +} + +print DST " ERTS_ALC_T_INVALID +}; + +const char *erts_alc_n2td[] = { + \"invalid_type\", +"; + +foreach my $t (@t_order) { + print DST " \"", get_description($t_tab{$t}), "\",\n"; +} + +print DST " NULL +}; + +const char *erts_alc_c2cd[] = { + \"invalid_class\", +"; + +foreach my $c (@c_order) { + print DST " \"", get_description($c_tab{$c}), "\",\n"; +} + +print DST " NULL +}; + +const char *erts_alc_a2ad[] = { + \"invalid_allocator\", +"; + +foreach my $a (@a_order) { + print DST " \"", get_description($a_tab{$a}), "\",\n"; +} + +print DST " NULL +}; +"; + +print DST " +#endif /* #ifdef ERTS_ALC_INTERNAL__ */ +"; + +# End of DST +print DST " + +/* ------------------------------------------------------------------------- */ +#endif /* #ifndef ERL_ALLOC_TYPES_H__ */ +"; + + +close(DST) or warn "$myname: Error closing $dst"; + +exit; + +############################################################################# +# Help routines +############################################################################# + +sub fits_in_bits { + my $val = shift; + my $bits; + + $val >= 0 or die "Expected value >= 0; got $val"; + + $bits = 0; + + while ($val != 0) { + $val >>= 1; + $bits++; + } + + return $bits; +} + +############################################################################# +# Table entries +# + +sub mk_entry { + my $d = shift; + my $a = shift; + my $c = shift; + return [$d, undef, [], $a, $c, undef]; +} + +sub get_description { + my $entry = shift; + return $entry->[0]; +} + +sub get_number { + my $entry = shift; + return $entry->[1]; +} + +sub get_types { + my $entry = shift; + return $entry->[2]; +} + +sub get_allocator { + my $entry = shift; + return $entry->[3]; +} + +sub get_class { + my $entry = shift; + return $entry->[4]; +} + +sub set_number { + my $entry = shift; + my $number = shift; + $entry->[1] = $number; +} + +sub add_type { + my $entry = shift; + my $t = shift; + push(@{$entry->[2]}, $t); +} + +sub set_multi_thread { + my $entry = shift; + $entry->[5] ='true'; +} + +sub get_multi_thread { + my $entry = shift; + return $entry->[5]; +} + +############################################################################# +# Preprocessing of a line + +sub preprocess_line { + my $line = shift; + $line =~ s/#.*$//; + $line =~ /^\s*(.*)$/; + $line = $1; + + if (!@cond_stack) { + push(@cond_stack, [undef, undef, undef, 'true', undef]); + } + + my $see_line = $cond_stack[@cond_stack - 1]->[3]; + + if ($line =~ /^(\S+)(.*)$/) { + my $ifdefop = $1; + my $ifdefarg = $2; + + if ($ifdefop eq '+if') { + $ifdefarg =~ /^\s*(\w+)\s*$/ or src_error("Bad '+if'"); + my $var = $1; + if ($see_line) { + $see_line = $bool_vars{$var}; + } + push(@cond_stack, ['+if', $var, undef, $see_line, $line_no]); + $see_line = undef; + } + elsif ($ifdefop eq '+ifnot') { + $ifdefarg =~ /^\s*(\w+)\s*$/ or src_error("Bad '+ifnot'"); + my $var = $1; + if ($see_line) { + $see_line = !$bool_vars{$var}; + } + push(@cond_stack, ['+ifnot', $var, undef, $see_line, $line_no]); + $see_line = undef; + } + elsif ($ifdefop eq '+else') { + $ifdefarg =~ /^\s*$/ or src_error("Garbage after '+else'"); + my $val = $cond_stack[@cond_stack - 1]; + $val->[0] or src_error("'+else' not matching anything"); + !$val->[2] or src_error("duplicate '+else'"); + $val->[2] = 'else'; + if ($see_line || $cond_stack[@cond_stack - 2]->[3]) { + $val->[3] = !$val->[3]; + } + $see_line = undef; + } + elsif ($ifdefop eq '+endif') { + $ifdefarg =~ /^\s*$/ or src_error("Garbage after '+endif'"); + my $val = pop(@cond_stack); + $val->[0] or src_error("'+endif' not matching anything"); + $see_line = undef; + } + elsif ($see_line) { + if ($ifdefop eq '+enable') { + $ifdefarg =~ /^\s*(\w+)\s*$/ or src_error("Bad '+enable'"); + $bool_vars{$1} = 'true'; + $see_line = undef; + } + elsif ($ifdefop eq '+disable') { + $ifdefarg =~ /^\s*(\w+)\s*$/ or src_error("Bad '+disable'"); + $bool_vars{$1} = undef; + $see_line = undef; + } + } + } + + return $see_line ? $line : ""; +} + +sub check_cond_stack { + my $val = $cond_stack[@cond_stack - 1]; + if ($val->[0]) { + $line_no = $val->[4]; + src_error("'", $val->[0], " ", $val->[1], "' not terminated\n"); + } +} + +sub check_reserved_words { + my $sort = shift; + my $name = shift; + my $descr = shift; + + !($name eq 'INVALID') + or src_error("Reserved $sort 'INVALID' declared"); + !($descr eq 'invalid_allocator') + or src_error("Reserved description 'invalid_allocator' used"); + !($descr eq 'invalid_class') + or src_error("Reserved description 'invalid_class' used"); + !($descr eq 'invalid_type') + or src_error("Reserved description 'invalid_type' used"); +} + +############################################################################# +# Error cases + +sub usage { + warn "$myname: ", @_, "\n"; + die "Usage: $myname -src <source> -dst <destination> [<var> ...]\n"; +} + +sub src_error { + die "$src:$line_no: ", @_, "\n"; +} + +sub duplicate_descr { + my $d = shift; + my $u = shift; + src_error("Description '$d' already used for '$u'"); +} + +sub invalid_decl { + my $decl = shift; + src_error("Invalid '$decl' declaration"); +} + +############################################################################# |