1#!/usr/bin/env perl 2# -*- cperl -*- 3 4# %CopyrightBegin% 5# 6# Copyright Ericsson AB 2003-2016. All Rights Reserved. 7# 8# Licensed under the Apache License, Version 2.0 (the "License"); 9# you may not use this file except in compliance with the License. 10# You may obtain a copy of the License at 11# 12# http://www.apache.org/licenses/LICENSE-2.0 13# 14# Unless required by applicable law or agreed to in writing, software 15# distributed under the License is distributed on an "AS IS" BASIS, 16# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 17# See the License for the specific language governing permissions and 18# limitations under the License. 19# 20# %CopyrightEnd% 21 22use strict; 23# use warnings; 24 25use File::Basename; 26 27# 28# Description: 29# Generates a header file containing defines for memory allocation types 30# from type declarations in a config file. 31# 32# Usage: 33# make_alloc_types -src <config-file> -dst <c-header-file> 34# 35# Options: 36# -src <config-file> 37# -dst <c-header-file> 38# [<enabled-boolean-variable> ...] 39# 40# Author: Rickard Green 41# 42 43my $myname = basename($0); 44my $src; 45my $dst; 46my %bool_vars; 47 48while (@ARGV && $ARGV[0]) { 49 my $opt = shift; 50 if ($opt eq '-src') { 51 $src = shift; 52 $src or die "$myname: Missing source file\n"; 53 } elsif ($opt eq '-dst') { 54 $dst = shift; 55 $dst or die "$myname: Missing destination file\n"; 56 } else { 57 $bool_vars{$opt} = 'true'; 58 } 59} 60 61$src or usage("Missing source file"); 62$dst or usage("Missing destination file"); 63 64open(SRC, "<$src") or die "$myname: Failed to open $src in read mode\n"; 65 66my $line; 67my $line_no = 0; 68my $decl; 69 70my %a_tab; 71my %c_tab; 72my %t_tab; 73my %d_tab; 74my @a_order; 75my @c_order; 76my @t_order; 77 78my @cond_stack; 79 80############################################################################# 81# Parse source file 82############################################################################# 83 84while ($line = <SRC>) { 85 $line_no = $line_no + 1; 86 $line = preprocess_line($line); 87 88 if ($line =~ /^(\S+)\s*(.*)/) { 89 $decl = $1; 90 $line = $2; 91 92 if ($decl eq 'type') { 93 if ($line =~ /^(\w+)\s+(\w+)\s+(\w+)\s+(\w+)\s*$/) { 94 my $t = $1; 95 my $a = $2; 96 my $c = $3; 97 my $d = $4; 98 99 check_reserved_words('type', $t, $d); 100 101 my $a_entry = $a_tab{$a}; 102 $a_entry or src_error("No allocator '$a' declared"); 103 my $c_entry = $c_tab{$c}; 104 $c_entry or src_error("No class '$c' declared"); 105 106 !$t_tab{$t} or src_error("Type '$t' already declared"); 107 my $d_user = $d_tab{$d}; 108 !$d_user or duplicate_descr($d, $d_user); 109 110 $t_tab{$t} = mk_entry($d, $a, $c); 111 add_type($a_entry, $t); 112 113 $d_tab{$d} = "type '$t'"; 114 115 } else { 116 invalid_decl($decl); 117 } 118 } elsif ($decl eq 'allocator') { 119 if ($line =~ /^(\w+)\s+(\w+)\s+(\w+)\s*$/) { 120 my $a = $1; 121 my $mt = $2; 122 my $d = $3; 123 124 check_reserved_words('allocator', $a, $d); 125 126 !$a_tab{$a} or src_error("Allocator '$a' already declared"); 127 my $d_user = $d_tab{$d}; 128 !$d_user or duplicate_descr($d, $d_user); 129 130 my $e = mk_entry($d); 131 $a_tab{$a} = $e; 132 133 if ($mt =~ /^true$/) { 134 set_multi_thread($e); 135 } 136 else { 137 $mt =~ /^false$/ or src_error("Multi-thread option not a boolean"); 138 } 139 140 $d_tab{$d} = "allocator '$a'"; 141 142 push(@a_order, $a); 143 144 } else { 145 invalid_decl($decl); 146 } 147 } elsif ($decl eq 'class') { 148 if ($line =~ /^(\w+)\s+(\w+)\s*$/) { 149 my $c = $1; 150 my $d = $2; 151 152 check_reserved_words('class', $c, $d); 153 154 !$c_tab{$c} or src_error("Class '$c' already declared"); 155 my $d_user = $d_tab{$d}; 156 !$d_user or duplicate_descr($d, $d_user); 157 158 $c_tab{$c} = mk_entry($d); 159 160 $d_tab{$d} = "class '$c'"; 161 162 } else { 163 invalid_decl($decl); 164 } 165 } else { 166 src_error("Unknown '$decl' declaration found"); 167 } 168 } 169} 170 171close(SRC) or warn "$myname: Error closing $src"; 172 173check_cond_stack(); 174 175############################################################################# 176# Create destination file 177############################################################################# 178 179mkdir(dirname($dst), 0777); 180open(DST, ">$dst") or die "$myname: Failed to open $dst in write mode\n"; 181 182print DST "/* 183 * ----------------------------------------------------------------------- 184 * 185 * NOTE: Do *not* edit this file; instead, edit '", basename($src),"' and 186 * build again! This file was automatically generated by 187 * '$myname' on ", (scalar localtime), ". 188 * 189 * ----------------------------------------------------------------------- 190 * 191 * 192 * Copyright Ericsson AB ", (1900 + (localtime)[5]), ". All Rights Reserved. 193 * 194 * Licensed under the Apache License, Version 2.0 (the \"License\"); 195 * you may not use this file except in compliance with the License. 196 * You may obtain a copy of the License at 197 * 198 * http://www.apache.org/licenses/LICENSE-2.0 199 * 200 * Unless required by applicable law or agreed to in writing, software 201 * distributed under the License is distributed on an \"AS IS\" BASIS, 202 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 203 * See the License for the specific language governing permissions and 204 * limitations under the License. 205 * 206 */ 207 208#ifndef ERL_ALLOC_TYPES_H__ 209#define ERL_ALLOC_TYPES_H__ 210 211"; 212 213my $a_no = 1; 214my $c_no = 1; 215my $t_no = 1; 216 217# Print allocator numbers ------------------------------------------------- 218 219print DST " 220/* --- Allocator numbers -------------------------------------------------- */ 221 222#define ERTS_ALC_A_INVALID (0) 223 224"; 225 226print DST "#define ERTS_ALC_A_MIN ($a_no)\n\n"; 227 228foreach my $a (@a_order) { 229 set_number($a_tab{$a}, $a_no); 230 print DST "#define ERTS_ALC_A_$a ($a_no)\n"; 231 $a_no++; 232} 233$a_no--; 234 235print DST "\n#define ERTS_ALC_A_MAX ($a_no)\n"; 236print DST "\n#define ERTS_ALC_A_COUNT (ERTS_ALC_A_MAX - ERTS_ALC_A_MIN + 1)\n"; 237 238# Print class numbers ----------------------------------------------------- 239 240print DST " 241 242/* --- Class numbers ------------------------------------------------------ */ 243 244#define ERTS_ALC_C_INVALID (0) 245 246"; 247 248print DST "#define ERTS_ALC_C_MIN ($c_no)\n\n"; 249 250foreach my $c (sort keys(%c_tab)) { 251 push(@c_order, $c); 252 set_number($c_tab{$c}, $c_no); 253 print DST "#define ERTS_ALC_C_$c ($c_no)\n"; 254 $c_no++; 255} 256$c_no--; 257print DST "\n#define ERTS_ALC_C_MAX ($c_no)\n"; 258print DST "\n#define ERTS_ALC_C_COUNT (ERTS_ALC_C_MAX - ERTS_ALC_C_MIN + 1)\n"; 259 260# Print type number intervals --------------------------------------------- 261 262print DST " 263 264/* --- Type number intervals ---------------------------------------------- */ 265 266#define ERTS_ALC_N_INVALID (0) 267 268"; 269 270print DST "#define ERTS_ALC_N_MIN ($t_no)\n\n"; 271 272foreach my $a (@a_order) { 273 my $a_entry = $a_tab{$a}; 274 my $ts = get_types($a_entry); 275 my $n_ts = @{$ts}; 276 if ($n_ts > 0) { 277 278 print DST "/* Type numbers used for ", get_description($a_entry), " */\n"; 279 print DST "#define ERTS_ALC_N_MIN_A_$a ($t_no)\n"; 280 281 foreach my $t (@{$ts}) { 282 push(@t_order, $t); 283 set_number($t_tab{$t}, $t_no); 284# print DST "#define ERTS_ALC_N_$t ($t_no)\n"; 285 $t_no++; 286 } 287 288 print DST "#define ERTS_ALC_N_MAX_A_$a (", $t_no - 1, ")\n\n"; 289 } 290 else { 291 print DST "/* No types use ", get_description($a_entry), " */\n\n"; 292 } 293} 294$t_no--; 295print DST "#define ERTS_ALC_N_MAX ($t_no)\n"; 296print DST "\n#define ERTS_ALC_N_COUNT (ERTS_ALC_N_MAX - ERTS_ALC_N_MIN + 1)\n"; 297 298# Print multi thread use of allocators ------------------------------------- 299 300print DST " 301 302/* --- Multi thread use of allocators -------------------------------------- */ 303 304"; 305 306foreach my $a (@a_order) { 307 my $mt = get_multi_thread($a_tab{$a}); 308 print DST "#define ERTS_ALC_MTA_$a (", $mt ? "1" : "0" ,")\n"; 309} 310 311 312# Calculate field sizes, masks, and shifts needed -------------------------- 313 314my $a_bits = fits_in_bits($a_no); 315my $c_bits = fits_in_bits($c_no); 316my $n_bits = fits_in_bits($t_no); 317my $t_bits = $a_bits + $n_bits + $c_bits; 318 319$n_bits <= 16 320 # Memory trace format expects type numbers to fit into an Uint16 321 or die("$myname: ", $t_no + 1, " types declared;", 322 " maximum number of types allowed are ", (1 << 16),"\n"); 323 324$t_bits <= 24 325 # We want 8 bits for flags (we actually only use 1 bit for flags 326 # at the time of writing)... 327 or die("$myname: More allocators, classes, and types declared than ", 328 "allowed\n"); 329 330my $a_mask = (1 << $a_bits) - 1; 331my $c_mask = (1 << $c_bits) - 1; 332my $n_mask = (1 << $n_bits) - 1; 333my $t_mask = (1 << $t_bits) - 1; 334 335my $a_shift = 0; 336my $c_shift = $a_bits + $a_shift; 337my $n_shift = $c_bits + $c_shift; 338 339 340# Print the types ---------------------------------------------------------- 341 342print DST " 343 344/* --- Types --------------------------------------------------------------- */ 345 346typedef Uint32 ErtsAlcType_t; /* The type used for memory types */ 347 348#define ERTS_ALC_T_INVALID (0) 349 350"; 351 352foreach my $t (@t_order) { 353 print DST 354 "#define ERTS_ALC_T_$t (", 355 ((get_number($a_tab{get_allocator($t_tab{$t})}) << $a_shift) 356 | (get_number($c_tab{get_class($t_tab{$t})}) << $c_shift) 357 | (get_number($t_tab{$t}) << $n_shift)), 358 ")\n"; 359} 360 361 362 363# Print field sizes, masks, and shifts needed ------------------------------ 364 365print DST " 366 367/* --- Field sizes, masks, and shifts -------------------------------------- */ 368 369#define ERTS_ALC_A_BITS ($a_bits) 370#define ERTS_ALC_C_BITS ($c_bits) 371#define ERTS_ALC_N_BITS ($n_bits) 372#define ERTS_ALC_T_BITS ($t_bits) 373 374#define ERTS_ALC_A_MASK ($a_mask) 375#define ERTS_ALC_C_MASK ($c_mask) 376#define ERTS_ALC_N_MASK ($n_mask) 377#define ERTS_ALC_T_MASK ($t_mask) 378 379#define ERTS_ALC_A_SHIFT ($a_shift) 380#define ERTS_ALC_C_SHIFT ($c_shift) 381#define ERTS_ALC_N_SHIFT ($n_shift) 382"; 383 384# Print mappings needed ---------------------------------------------------- 385 386print DST " 387 388/* --- Mappings ------------------------------------------------------------ */ 389 390/* type -> type number */ 391#define ERTS_ALC_T2N(T) (((T) >> ERTS_ALC_N_SHIFT) & ERTS_ALC_N_MASK) 392 393/* type -> allocator number */ 394#define ERTS_ALC_T2A(T) (((T) >> ERTS_ALC_A_SHIFT) & ERTS_ALC_A_MASK) 395 396/* type -> class number */ 397#define ERTS_ALC_T2C(T) (((T) >> ERTS_ALC_C_SHIFT) & ERTS_ALC_C_MASK) 398 399/* type number -> type */ 400#define ERTS_ALC_N2T(N) (erts_alc_n2t[(N)]) 401 402/* type number -> type description */ 403#define ERTS_ALC_N2TD(N) (erts_alc_n2td[(N)]) 404 405/* type -> type description */ 406#define ERTS_ALC_T2TD(T) (ERTS_ALC_N2TD(ERTS_ALC_T2N((T)))) 407 408/* class number -> class description */ 409#define ERTS_ALC_C2CD(C) (erts_alc_c2cd[(C)]) 410 411/* allocator number -> allocator description */ 412#define ERTS_ALC_A2AD(A) (erts_alc_a2ad[(A)]) 413 414extern const ErtsAlcType_t erts_alc_n2t[]; 415extern const char *erts_alc_n2td[]; 416extern const char *erts_alc_c2cd[]; 417extern const char *erts_alc_a2ad[]; 418 419#ifdef ERTS_ALC_INTERNAL__ 420 421const ErtsAlcType_t erts_alc_n2t[] = { 422 ERTS_ALC_T_INVALID, 423"; 424 425foreach my $t (@t_order) { 426 print DST " ERTS_ALC_T_$t,\n"; 427} 428 429print DST " ERTS_ALC_T_INVALID 430}; 431 432const char *erts_alc_n2td[] = { 433 \"invalid_type\", 434"; 435 436foreach my $t (@t_order) { 437 print DST " \"", get_description($t_tab{$t}), "\",\n"; 438} 439 440print DST " NULL 441}; 442 443const char *erts_alc_c2cd[] = { 444 \"invalid_class\", 445"; 446 447foreach my $c (@c_order) { 448 print DST " \"", get_description($c_tab{$c}), "\",\n"; 449} 450 451print DST " NULL 452}; 453 454const char *erts_alc_a2ad[] = { 455 \"invalid_allocator\", 456"; 457 458foreach my $a (@a_order) { 459 print DST " \"", get_description($a_tab{$a}), "\",\n"; 460} 461 462print DST " NULL 463}; 464"; 465 466print DST " 467#endif /* #ifdef ERTS_ALC_INTERNAL__ */ 468"; 469 470# End of DST 471print DST " 472 473/* ------------------------------------------------------------------------- */ 474#endif /* #ifndef ERL_ALLOC_TYPES_H__ */ 475"; 476 477 478close(DST) or warn "$myname: Error closing $dst"; 479 480exit; 481 482############################################################################# 483# Help routines 484############################################################################# 485 486sub fits_in_bits { 487 my $val = shift; 488 my $bits; 489 490 $val >= 0 or die "Expected value >= 0; got $val"; 491 492 $bits = 0; 493 494 while ($val != 0) { 495 $val >>= 1; 496 $bits++; 497 } 498 499 return $bits; 500} 501 502############################################################################# 503# Table entries 504# 505 506sub mk_entry { 507 my $d = shift; 508 my $a = shift; 509 my $c = shift; 510 return [$d, undef, [], $a, $c, undef]; 511} 512 513sub get_description { 514 my $entry = shift; 515 return $entry->[0]; 516} 517 518sub get_number { 519 my $entry = shift; 520 return $entry->[1]; 521} 522 523sub get_types { 524 my $entry = shift; 525 return $entry->[2]; 526} 527 528sub get_allocator { 529 my $entry = shift; 530 return $entry->[3]; 531} 532 533sub get_class { 534 my $entry = shift; 535 return $entry->[4]; 536} 537 538sub set_number { 539 my $entry = shift; 540 my $number = shift; 541 $entry->[1] = $number; 542} 543 544sub add_type { 545 my $entry = shift; 546 my $t = shift; 547 push(@{$entry->[2]}, $t); 548} 549 550sub set_multi_thread { 551 my $entry = shift; 552 $entry->[5] ='true'; 553} 554 555sub get_multi_thread { 556 my $entry = shift; 557 return $entry->[5]; 558} 559 560############################################################################# 561# Preprocessing of a line 562 563sub preprocess_line { 564 my $line = shift; 565 $line =~ s/#.*$//; 566 $line =~ /^\s*(.*)$/; 567 $line = $1; 568 569 if (!@cond_stack) { 570 push(@cond_stack, [undef, undef, undef, 'true', undef]); 571 } 572 573 my $see_line = $cond_stack[@cond_stack - 1]->[3]; 574 575 if ($line =~ /^(\S+)(.*)$/) { 576 my $ifdefop = $1; 577 my $ifdefarg = $2; 578 579 if ($ifdefop eq '+if') { 580 $ifdefarg =~ /^\s*(\w+)\s*$/ or src_error("Bad '+if'"); 581 my $var = $1; 582 if ($see_line) { 583 $see_line = $bool_vars{$var}; 584 } 585 push(@cond_stack, ['+if', $var, undef, $see_line, $line_no]); 586 $see_line = undef; 587 } 588 elsif ($ifdefop eq '+ifnot') { 589 $ifdefarg =~ /^\s*(\w+)\s*$/ or src_error("Bad '+ifnot'"); 590 my $var = $1; 591 if ($see_line) { 592 $see_line = !$bool_vars{$var}; 593 } 594 push(@cond_stack, ['+ifnot', $var, undef, $see_line, $line_no]); 595 $see_line = undef; 596 } 597 elsif ($ifdefop eq '+else') { 598 $ifdefarg =~ /^\s*$/ or src_error("Garbage after '+else'"); 599 my $val = $cond_stack[@cond_stack - 1]; 600 $val->[0] or src_error("'+else' not matching anything"); 601 !$val->[2] or src_error("duplicate '+else'"); 602 $val->[2] = 'else'; 603 if ($see_line || $cond_stack[@cond_stack - 2]->[3]) { 604 $val->[3] = !$val->[3]; 605 } 606 $see_line = undef; 607 } 608 elsif ($ifdefop eq '+endif') { 609 $ifdefarg =~ /^\s*$/ or src_error("Garbage after '+endif'"); 610 my $val = pop(@cond_stack); 611 $val->[0] or src_error("'+endif' not matching anything"); 612 $see_line = undef; 613 } 614 elsif ($see_line) { 615 if ($ifdefop eq '+enable') { 616 $ifdefarg =~ /^\s*(\w+)\s*$/ or src_error("Bad '+enable'"); 617 $bool_vars{$1} = 'true'; 618 $see_line = undef; 619 } 620 elsif ($ifdefop eq '+disable') { 621 $ifdefarg =~ /^\s*(\w+)\s*$/ or src_error("Bad '+disable'"); 622 $bool_vars{$1} = undef; 623 $see_line = undef; 624 } 625 } 626 } 627 628 return $see_line ? $line : ""; 629} 630 631sub check_cond_stack { 632 my $val = $cond_stack[@cond_stack - 1]; 633 if ($val->[0]) { 634 $line_no = $val->[4]; 635 src_error("'", $val->[0], " ", $val->[1], "' not terminated\n"); 636 } 637} 638 639sub check_reserved_words { 640 my $sort = shift; 641 my $name = shift; 642 my $descr = shift; 643 644 !($name eq 'INVALID') 645 or src_error("Reserved $sort 'INVALID' declared"); 646 !($descr eq 'invalid_allocator') 647 or src_error("Reserved description 'invalid_allocator' used"); 648 !($descr eq 'invalid_class') 649 or src_error("Reserved description 'invalid_class' used"); 650 !($descr eq 'invalid_type') 651 or src_error("Reserved description 'invalid_type' used"); 652} 653 654############################################################################# 655# Error cases 656 657sub usage { 658 warn "$myname: ", @_, "\n"; 659 die "Usage: $myname -src <source> -dst <destination> [<var> ...]\n"; 660} 661 662sub src_error { 663 die "$src:$line_no: ", @_, "\n"; 664} 665 666sub duplicate_descr { 667 my $d = shift; 668 my $u = shift; 669 src_error("Description '$d' already used for '$u'"); 670} 671 672sub invalid_decl { 673 my $decl = shift; 674 src_error("Invalid '$decl' declaration"); 675} 676 677############################################################################# 678