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