URL
https://opencores.org/ocsvn/an-fpga-implementation-of-low-latency-noc-based-mpsoc/an-fpga-implementation-of-low-latency-noc-based-mpsoc/trunk
Subversion Repositories an-fpga-implementation-of-low-latency-noc-based-mpsoc
Compare Revisions
- This comparison shows the changes necessary to convert path
/an-fpga-implementation-of-low-latency-noc-based-mpsoc/trunk/mpsoc/Integration_test
- from Rev 55 to Rev 56
- ↔ Reverse comparison
Rev 55 → Rev 56
/Altera/report
0,0 → 1,47
extract_results(/home/alireza/work/git/hca_git/mpsoc_work/verify/quartus_pronoc,pronoc); |
/home/alireza/work/git/hca_git/mpsoc_work/verify/quartus_pronoc |
***************** results ***************** |
, Fr_max |
pronoc_output_files, 125.9 , Fmax = 125.9 Mhz |
|
|
|
|
-, Combinational ALUTs |
pronoc_output_files, 12032 , 36100 ( 33 % ) ; |
|
|
|
|
-, Dedicated logic registers |
pronoc_output_files, 9376 , 36100 ( 26 % ) ; |
|
|
|
|
-, Memory ALUTs |
pronoc_output_files, 0 , 18050 ( 0 % ) ; |
|
|
|
|
-, ALMs: partially or completely used |
pronoc_output_files, 9309 , 18050 ( 52 % ) |
|
|
|
|
-, Logic utilization |
pronoc_output_files, 14767 , 36100 ( 41 % ) |
|
|
|
|
-, M9K blocks |
pronoc_output_files, 33 , 319 ( 10 % ) ; |
|
|
|
|
-, Total block memory bits |
pronoc_output_files, 16320 , 2939904 ( < 1 % ) ; |
/Altera/report_old
0,0 → 1,46
***************** results ***************** |
, Fr_max |
pronoc_output_files, 125.5 , Fmax = 125.5 Mhz |
|
|
|
|
-, Combinational ALUTs |
pronoc_output_files, 12019 , 36100 ( 33 % ) ; |
|
|
|
|
-, Dedicated logic registers |
pronoc_output_files, 9370 , 36100 ( 26 % ) ; |
|
|
|
|
-, Memory ALUTs |
pronoc_output_files, 0 , 18050 ( 0 % ) ; |
|
|
|
|
-, ALMs: partially or completely used |
pronoc_output_files, 9253 , 18050 ( 51 % ) |
|
|
|
|
-, Logic utilization |
pronoc_output_files, 15031 , 36100 ( 42 % ) |
|
|
|
|
-, M9K blocks |
pronoc_output_files, 33 , 319 ( 10 % ) ; |
|
|
|
|
-, Total block memory bits |
pronoc_output_files, 16320 , 2939904 ( < 1 % ) ; |
|
/Altera/run.sh
0,0 → 1,129
#!/bin/bash |
|
SCRPT_FULL_PATH=$(realpath ${BASH_SOURCE[0]}) |
SCRPT_DIR_PATH=$(dirname $SCRPT_FULL_PATH) |
|
|
|
|
work="${PRONOC_WORK}/verify/quartus_pronoc" |
top="quartus_pronoc" |
|
|
|
|
|
|
|
|
|
copy_filelist () { |
fname=$1 |
local DIR="$(dirname "${fname}")" |
|
|
echo $DIR |
pwd |
|
|
while read line; do |
# reading each line |
#echo $line |
cd $DIR |
|
if test -f "$DIR/$line"; then |
echo "copy $DIR/$line " |
cp "$DIR/$line" $PITON_ROOT/build/src_verilog/ |
fi |
line="$(echo -e "${line}" | sed -e 's/^[[:space:]]*//')" # remove only the leading white spaces |
if [[ $line == -F* ]] || [[ $line == -f* ]] ; then |
line=${line:2} # Remove the first three chars (leaving 4..end) |
line="$(echo -e "${line}" | sed -e 's/^[[:space:]]*//')" # remove only the leading white spaces |
echo $line |
echo "got another file list $line" |
copy_filelist "$DIR/$line" |
fi |
done < $fname |
} |
|
|
|
|
|
|
make_qsf () { |
fname=$1 |
oname=$2 |
local DIR="$(dirname "${fname}")" |
|
|
echo $oname |
|
pwd |
|
|
while read line; do |
# reading each line |
#echo $line |
cd $DIR |
|
|
if test -f "$DIR/$line"; then |
echo "set_global_assignment -name SYSTEMVERILOG_FILE $DIR/$line">>"$oname" |
# "$DIR/$line" $PITON_ROOT/build/src_verilog/ |
fi |
line="$(echo -e "${line}" | sed -e 's/^[[:space:]]*//')" # remove only the leading white spaces |
if [[ $line == -F* ]] || [[ $line == -f* ]] ; then |
line=${line:2} # Remove the first three chars (leaving 4..end) |
line="$(echo -e "${line}" | sed -e 's/^[[:space:]]*//')" # remove only the leading white spaces |
#echo $line |
echo "got another file list $line" |
make_qsf "$DIR/$line" "$oname" |
fi |
|
if [[ $line == +incdir+* ]] ; then |
line=${line:8} # Remove the first three chars (leaving 4..end) |
echo "set_global_assignment -name SEARCH_PATH $DIR/$line">>"$oname" |
fi |
|
done < $fname |
} |
|
|
compile () { |
|
mkdir -p $work |
filename=$SCRPT_DIR_PATH/src/file_list.f |
qsf_name="$work/pronoc.qsf" |
cp -f $SCRPT_DIR_PATH/src/pronoc.qsf $qsf_name |
|
echo "set_global_assignment -name TOP_LEVEL_ENTITY $top">>$qsf_name |
make_qsf $filename "$qsf_name" |
|
|
|
|
if [[ -z "${Quartus_bin}" ]]; then |
#"Some default value because Quartus_bin is undefined" |
Quartus_bin="/home/alireza/intelFPGA_lite/18.1/quartus/bin" |
else |
Quartus_bin="${Quartus_bin}" |
fi |
|
cd $work |
$Quartus_bin/quartus_map --64bit pronoc --read_settings_files=on |
$Quartus_bin/quartus_fit --64bit pronoc --read_settings_files=on |
$Quartus_bin/quartus_asm --64bit pronoc --read_settings_files=on |
$Quartus_bin/quartus_sta --64bit pronoc |
|
} |
|
|
compile |
|
wait; |
|
perl ${SCRPT_DIR_PATH}/src/extract.prl "$PRONOC_WORK/verify/quartus_pronoc" "pronoc" > report |
|
|
|
Altera/run.sh
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: Altera/src/altera_reset_synchronizer.v
===================================================================
--- Altera/src/altera_reset_synchronizer.v (nonexistent)
+++ Altera/src/altera_reset_synchronizer.v (revision 56)
@@ -0,0 +1,91 @@
+// (C) 2001-2013 Altera Corporation. All rights reserved.
+// Your use of Altera Corporation's design tools, logic functions and other
+// software and tools, and its AMPP partner logic functions, and any output
+// files any of the foregoing (including device programming or simulation
+// files), and any associated documentation or information are expressly subject
+// to the terms and conditions of the Altera Program License Subscription
+// Agreement, Altera MegaCore Function License Agreement, or other applicable
+// license agreement, including, without limitation, that your use is for the
+// sole purpose of programming logic devices manufactured by Altera and sold by
+// Altera or its authorized distributors. Please refer to the applicable
+// agreement for further details.
+
+
+// $Id: //acds/rel/13.0/ip/merlin/altera_reset_controller/altera_reset_synchronizer.v#1 $
+// $Revision: #1 $
+// $Date: 2013/02/11 $
+// $Author: swbranch $
+
+// -----------------------------------------------
+// Reset Synchronizer
+// -----------------------------------------------
+
+// synthesis translate_off
+`timescale 1ns / 1ps
+// synthesis translate_on
+
+
+module altera_reset_synchronizer
+#(
+ parameter ASYNC_RESET = 0,
+ parameter DEPTH = 2
+)
+(
+ input reset_in /* synthesis ALTERA_ATTRIBUTE = "SUPPRESS_DA_RULE_INTERNAL=R101" */,
+
+ input clk,
+ output reset_out
+);
+
+ // -----------------------------------------------
+ // Synchronizer register chain. We cannot reuse the
+ // standard synchronizer in this implementation
+ // because our timing constraints are different.
+ //
+ // Instead of cutting the timing path to the d-input
+ // on the first flop we need to cut the aclr input.
+ //
+ // We omit the "preserve" attribute on the final
+ // output register, so that the synthesis tool can
+ // duplicate it where needed.
+ // -----------------------------------------------
+ (*preserve*) reg [DEPTH-1:0] altera_reset_synchronizer_int_chain;
+ reg altera_reset_synchronizer_int_chain_out;
+
+ generate if (ASYNC_RESET) begin
+
+ // -----------------------------------------------
+ // Assert asynchronously, deassert synchronously.
+ // -----------------------------------------------
+ always @(posedge clk or posedge reset_in) begin
+ if (reset_in) begin
+ altera_reset_synchronizer_int_chain <= {DEPTH{1'b1}};
+ altera_reset_synchronizer_int_chain_out <= 1'b1;
+ end
+ else begin
+ altera_reset_synchronizer_int_chain[DEPTH-2:0] <= altera_reset_synchronizer_int_chain[DEPTH-1:1];
+ altera_reset_synchronizer_int_chain[DEPTH-1] <= 0;
+ altera_reset_synchronizer_int_chain_out <= altera_reset_synchronizer_int_chain[0];
+ end
+ end
+
+ assign reset_out = altera_reset_synchronizer_int_chain_out;
+
+ end else begin
+
+ // -----------------------------------------------
+ // Assert synchronously, deassert synchronously.
+ // -----------------------------------------------
+ always @(posedge clk) begin
+ altera_reset_synchronizer_int_chain[DEPTH-2:0] <= altera_reset_synchronizer_int_chain[DEPTH-1:1];
+ altera_reset_synchronizer_int_chain[DEPTH-1] <= reset_in;
+ altera_reset_synchronizer_int_chain_out <= altera_reset_synchronizer_int_chain[0];
+ end
+
+ assign reset_out = altera_reset_synchronizer_int_chain_out;
+
+ end
+ endgenerate
+
+endmodule
+
Altera/src/altera_reset_synchronizer.v
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: Altera/src/extract.prl
===================================================================
--- Altera/src/extract.prl (nonexistent)
+++ Altera/src/extract.prl (revision 56)
@@ -0,0 +1,116 @@
+#!/usr/bin/perl -w
+use Cwd qw(getcwd);
+use IPC::Run qw( run start pump finish timeout );
+
+
+
+my @HWs = (
+"; Logic utilization ;",
+"; Combinational ALUTs ;",
+"; Memory ALUTs ;",
+"; Dedicated logic registers ;",
+"; Total block memory bits ;",
+"; ALMs: partially or completely used ;",
+"; M9K blocks ;"
+
+);
+
+
+
+my $csv="";
+my %freq;
+my %results;
+
+sub extract_results {
+ my ($dir,$parent) =@_;
+ my @cat = qw( bash );
+ chdir "$dir";
+ print getcwd()."\n";
+
+ my ($in, $out, $err);
+ #Fmax
+ $in ='grep -R "; clk ; ;$" | sort';
+ run \@cat, \$in, \$out, \$err, timeout( 10 ) or die "grep: $?";
+
+
+ my @lines = split("\n",$out);
+ foreach my $l (@lines) {
+
+ my @f=split ('/',$l);
+ my $name= "${parent}_$f[0]";
+
+ @f=split (':',$l);
+ @f=split (';',$f[1]);
+ $f[1] =~ s/MHz//;
+
+ if(!defined $freq{$name}){
+ $freq{$name}=$f[1];
+ }else{#get the minum reported max frequency
+ $freq{$name}=$f[1] if($f[1]< $freq{$name});
+ }
+
+ }
+
+
+
+
+ foreach my $hw (@HWs){
+
+
+
+ my @cat = qw( bash );
+ my $in ="grep -R \"$hw\" | sort";
+ $hw =~ s/[\;]//g;
+
+ #$csv.="-,$hw\n";
+ $out=undef;
+ run \@cat, \$in, \$out, \$err, timeout( 10 ) or die "grep: $?";
+ @lines = split("\n",$out);
+
+ foreach my $l (@lines) {
+ unless ( index($l,".fit.rpt") >= 0){ next;}
+
+ my @f=split ('/',$l);
+
+ my $name= "${parent}_$f[0]";
+ my @ff = split (/\; /,$l);
+ my $val=$ff[2];
+ $val =~ s/,//g;
+ my @vv = split ("/",$val);
+ my $t =join(',',@vv);
+ #$csv.= "$name, $t \n" if (defined $val) ;
+ $results{$hw}{$name}=$t if (defined $val) ;
+ }
+ }
+
+}
+
+
+
+print "extract_results($ARGV[0],$ARGV[1]);\n";
+
+extract_results($ARGV[0],$ARGV[1]);
+
+
+
+
+$csv.=" , Fr_max\n";
+foreach my $p (sort keys %freq){
+ $csv.= "$p, $freq{$p}, Fmax = $freq{$p} Mhz\n";
+}
+
+
+foreach my $p (sort keys %results){
+ my $ref = $results{$p};
+ my %r = %{$results{$p}} if (defined $ref) ;
+ $csv.= "\n\n\n\n" ;
+ $csv.="-,$p\n";
+ foreach my $p (sort keys %r){
+ $csv.= "$p, $r{$p} \n";
+ }
+
+}
+
+print "***************** results *****************\n";
+ print $csv;
+
Altera/src/extract.prl
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: Altera/src/file_list.f
===================================================================
--- Altera/src/file_list.f (nonexistent)
+++ Altera/src/file_list.f (revision 56)
@@ -0,0 +1,9 @@
++incdir+./
++incdir+./../../../rtl/src_noc
+
+-F ../../../rtl/src_noc/noc_filelist.f
+-F ../../../rtl/src_topolgy/custom_flist.f
+
+./quartus_piton_mesh.sv
+./quartus_pronoc.sv
+./altera_reset_synchronizer.v
Index: Altera/src/noc_localparam.v
===================================================================
--- Altera/src/noc_localparam.v (nonexistent)
+++ Altera/src/noc_localparam.v (revision 56)
@@ -0,0 +1,50 @@
+
+`ifdef NOC_LOCAL_PARAM
+
+
+
+
+//NoC parameters
+ localparam TOPOLOGY="MESH";
+ localparam T1=3;
+ localparam T2=3;
+ localparam T3=1;
+ localparam V=2;
+ localparam B=4;
+ localparam LB=16;
+ localparam Fpay=32;
+ localparam ROUTE_NAME="XY";
+ localparam PCK_TYPE = "MULTI_FLIT"; //"SINGLE_FLIT";
+ localparam MIN_PCK_SIZE=1;
+ localparam BYTE_EN=0;
+ localparam SSA_EN="YES";
+ localparam CONGESTION_INDEX=3;
+ localparam ESCAP_VC_MASK=2'b01;
+ localparam VC_REALLOCATION_TYPE="NONATOMIC";
+ localparam COMBINATION_TYPE="COMB_NONSPEC";
+ localparam MUX_TYPE="BINARY";
+ localparam C=0;
+ localparam DEBUG_EN=1;
+ localparam ADD_PIPREG_AFTER_CROSSBAR=1'b0;
+ localparam FIRST_ARBITER_EXT_P_EN=1;
+ localparam SWA_ARBITER_TYPE="RRA";
+ localparam WEIGHTw=4;
+ localparam AVC_ATOMIC_EN=0;
+ localparam CVw=(C==0)? V : C * V;
+ localparam CLASS_SETTING={CVw{1'b1}};
+ localparam SMART_MAX=0;
+ localparam SELF_LOOP_EN="YES";
+ localparam CAST_TYPE = "UNICAST";
+ localparam MCAST_ENDP_LIST = 'b11110011;
+ //localparam MCAST_PRTLw=6;
+
+
+
+ //simulation parameter
+ //localparam MAX_RATIO = 1000;
+ localparam MAX_PCK_NUM = 1000000000;
+ localparam MAX_PCK_SIZ = 16383;
+ localparam MAX_SIM_CLKs= 1000000000;
+ localparam TIMSTMP_FIFO_NUM = 16;
+
+`endif
Index: Altera/src/pronoc.qsf
===================================================================
--- Altera/src/pronoc.qsf (nonexistent)
+++ Altera/src/pronoc.qsf (revision 56)
@@ -0,0 +1,75 @@
+# Generated using ProNoC
+#============================================================
+# Build by Terasic System Builder
+#============================================================
+
+set_global_assignment -name FAMILY "Arria II GX"
+set_global_assignment -name DEVICE EP2AGX45DF29I5
+set_global_assignment -name ORIGINAL_QUARTUS_VERSION 12.0
+set_global_assignment -name LAST_QUARTUS_VERSION "18.1.0 Lite Edition"
+set_global_assignment -name PROJECT_CREATION_TIME_DATE "16:38:23 JULY 08,2019"
+
+#============================================================
+# CLOCK
+#============================================================
+
+#============================================================
+# LED x 10
+#============================================================
+
+#============================================================
+# BUTTON x 4 and CPU_RESET_n
+#============================================================
+
+#============================================================
+# SWITCH x 4
+#============================================================
+
+#============================================================
+# 7-Segement
+#============================================================
+
+#============================================================
+# Temperature
+#============================================================
+
+#============================================================
+# Fan
+#============================================================
+
+#============================================================
+# RS232
+#============================================================
+
+#============================================================
+# Flash/MAX Address/Data Share Bus
+#============================================================
+
+#============================================================
+# Flash Control
+#============================================================
+
+#============================================================
+# End of pin assignments by Terasic System Builder
+#============================================================
+
+
+set_global_assignment -name PROJECT_OUTPUT_DIRECTORY output_files
+
+
+
+set_global_assignment -name MIN_CORE_JUNCTION_TEMP "-40"
+set_global_assignment -name MAX_CORE_JUNCTION_TEMP 100
+set_global_assignment -name POWER_PRESET_COOLING_SOLUTION "23 MM HEAT SINK WITH 200 LFPM AIRFLOW"
+set_global_assignment -name POWER_BOARD_THERMAL_MODEL "NONE (CONSERVATIVE)"
+
+
+set_global_assignment -name PARTITION_NETLIST_TYPE SOURCE -section_id Top
+set_global_assignment -name PARTITION_FITTER_PRESERVATION_LEVEL PLACEMENT_AND_ROUTING -section_id Top
+set_global_assignment -name PARTITION_COLOR 16764057 -section_id Top
+set_instance_assignment -name PARTITION_HIERARCHY root_partition -to | -section_id Top
+
+
+
+
+
Index: Altera/src/quartus_pronoc.sv
===================================================================
--- Altera/src/quartus_pronoc.sv (nonexistent)
+++ Altera/src/quartus_pronoc.sv (revision 56)
@@ -0,0 +1,67 @@
+`include "pronoc_def.v"
+
+module quartus_pronoc
+#(
+ parameter NOC_ID = 0
+)(
+ clk,
+ reset,
+ chan_in,
+ chan_out,
+ sel_in,
+ sel_out
+);
+
+ `NOC_CONF
+
+ input [NE-1 : 0] sel_in;
+ input [NEw-1 : 0] sel_out;
+ input smartflit_chanel_t chan_in;
+ output smartflit_chanel_t chan_out;
+ input reset,clk;
+
+
+ smartflit_chanel_t chan_in_all [NE-1 : 0];
+ smartflit_chanel_t chan_out_all [NE-1 : 0];
+ smartflit_chanel_t chan_out_all_reg [NE-1 : 0];
+
+ wire noc_reset;
+
+ noc_top #(
+ .NOC_ID(NOC_ID)
+ ) top (
+ .reset(noc_reset),
+ .clk(clk),
+ .chan_in_all(chan_in_all),
+ .chan_out_all(chan_out_all),
+ .router_event( )
+ );
+
+
+ altera_reset_synchronizer sync(
+ .reset_in (reset),
+ .clk (clk),
+ .reset_out (noc_reset)
+ );
+
+ //NoC port assignment
+
+ assign chan_out = chan_out_all_reg[sel_out];
+
+ always @(posedge clk) begin
+ chan_out_all_reg <= chan_out_all;
+ end
+
+ genvar IP_NUM;
+ generate
+ for (IP_NUM=0; IP_NUM "verilate_mesh.sh",
+ 'noc_param'=> {
+ "ROUTE_NAME" => "\"XY\"",
+ }
+}, 'ProNOC' );
Index: FPGA-kc07/src/deafult_noc_param
===================================================================
--- FPGA-kc07/src/deafult_noc_param (nonexistent)
+++ FPGA-kc07/src/deafult_noc_param (revision 56)
@@ -0,0 +1,82 @@
+$model = bless( {
+ 'noc_param' => {
+"TOPOLOGY" => "\"MESH\"",
+"T1" => "4",
+"T2" => "4",
+"T3" => "1",
+"V" => "1",
+"B" => "4",
+"LB" => "B",
+"Fpay" => "32",
+"ROUTE_NAME" => "\"XY\"",
+"PCK_TYPE" => " \"MULTI_FLIT\"",
+"MIN_PCK_SIZE" => "2",
+"BYTE_EN" => "0",
+"SSA_EN" => "\"NO\"",
+"CONGESTION_INDEX" => "3",
+"ESCAP_VC_MASK" => "2'b01",
+"VC_REALLOCATION_TYPE" => "\"NONATOMIC\"",
+"COMBINATION_TYPE" => "\"COMB_NONSPEC\"",
+"MUX_TYPE" => "\"BINARY\"",
+"C" => "0",
+"CLASS_SETTING"=> "{V{1'b1}}",
+"DEBUG_EN" => "1",
+"ADD_PIPREG_AFTER_CROSSBAR" => "1'b0",
+"FIRST_ARBITER_EXT_P_EN" => "1",
+"SWA_ARBITER_TYPE" => "\"RRA\"",
+"WEIGHTw" => "4",
+"AVC_ATOMIC_EN" => "0",
+"SMART_MAX" => "0",
+"SELF_LOOP_EN" => "\"NO\"",
+"MAX_PCK_NUM " => " 1000000000",
+"MAX_PCK_SIZ " => " 16383" ,
+"MAX_SIM_CLKs" => " 1000000000",
+"TIMSTMP_FIFO_NUM " => " 16",
+"CVw"=> "(C==0)? V : C * V",
+"CLASS_SETTING" => "{CVw{1'b1}}",
+"CAST_TYPE" => "\"UNICAST\"",
+ },
+
+
+ 'parameters_order' => {
+'noc_param' =>
+[
+ 'TOPOLOGY',
+ 'T1',
+ 'T2',
+ 'T3',
+ 'V',
+ 'B',
+ 'LB',
+ 'Fpay',
+ 'ROUTE_NAME',
+ 'PCK_TYPE',
+ 'MIN_PCK_SIZE',
+ 'BYTE_EN',
+ 'SSA_EN',
+ 'SMART_MAX',
+ 'CONGESTION_INDEX',
+ 'ESCAP_VC_MASK',
+ 'VC_REALLOCATION_TYPE',
+ 'COMBINATION_TYPE',
+ 'MUX_TYPE',
+ 'C',
+'CLASS_SETTING',
+ 'DEBUG_EN',
+ 'ADD_PIPREG_AFTER_CROSSBAR',
+ 'FIRST_ARBITER_EXT_P_EN',
+ 'SWA_ARBITER_TYPE',
+ 'WEIGHTw',
+ 'SELF_LOOP_EN',
+ 'AVC_ATOMIC_EN',
+"MAX_PCK_NUM " ,
+"MAX_PCK_SIZ ",
+"MAX_SIM_CLKs",
+"TIMSTMP_FIFO_NUM ",
+"CVw",
+"CAST_TYPE" ],
+
+}
+
+ },
+);
Index: FPGA-kc07/src/src.pl
===================================================================
--- FPGA-kc07/src/src.pl (nonexistent)
+++ FPGA-kc07/src/src.pl (revision 56)
@@ -0,0 +1,470 @@
+#!/usr/bin/perl -w
+
+use Proc::Background;
+use File::Path qw( rmtree );
+
+my $script_path = dirname(__FILE__);
+my $dirname = "$script_path/..";
+my $root = "$dirname/../..";
+my $rtl_dir = "$ENV{PRONOC_WORK}/verify/rtl";
+my $work = "$ENV{PRONOC_WORK}/verify/work";
+my $src = "$script_path";
+my $report = "$dirname/report";
+
+require "$root/perl_gui/lib/perl/common.pl";
+require "$root/perl_gui/lib/perl/topology.pl";
+
+use strict;
+use warnings;
+
+my $pp;
+$pp= do "$src/deafult_noc_param";
+die "Error reading: $@" if $@;
+
+my $param = $pp->{'noc_param'};
+my %default_noc_param=%{$param};
+my @params=object_get_attribute_order($pp,'noc_param');
+
+
+
+#read default param
+
+
+sub gen_noc_param_h{
+ my $mpsoc=shift;
+ my $param_h="\n\n//NoC parameters\n";
+
+ my $topology = $mpsoc->object_get_attribute('noc_param','TOPOLOGY');
+ $topology =~ s/"//g;
+ $param_h.="\t#define IS_${topology}\n";
+
+ my ($NE, $NR, $RAw, $EAw, $Fw) = get_topology_info($mpsoc);
+
+ my @params=$mpsoc->object_get_attribute_order('noc_param');
+ my $custom_topology = $mpsoc->object_get_attribute('noc_param','CUSTOM_TOPOLOGY_NAME');
+ foreach my $p (@params){
+ my $val=$mpsoc->object_get_attribute('noc_param',$p);
+ next if($p eq "CUSTOM_TOPOLOGY_NAME");
+ $val=$custom_topology if($p eq "TOPOLOGY" && $val eq "\"CUSTOM\"");
+ if($p eq "MCAST_ENDP_LIST" || $p eq "ESCAP_VC_MASK"){
+ $val="$NE".$val if($p eq 'MCAST_ENDP_LIST');
+ $val =~ s/\'/\\\'/g;
+ $val="\"$val\"";
+ }
+
+
+ $param_h=$param_h."\t#define $p\t$val\n";
+
+
+
+ }
+ my $class=$mpsoc->object_get_attribute('noc_param',"C");
+ my $str;
+ if( $class > 1){
+ for (my $i=0; $i<=$class-1; $i++){
+ my $n="Cn_$i";
+ my $val=$mpsoc->object_get_attribute('class_param',$n);
+ $param_h=$param_h."\t#define $n\t$val\n";
+ }
+ $str="CLASS_SETTING {";
+ for (my $i=$class-1; $i>=0;$i--){
+ $str=($i==0)? "${str}Cn_0};\n " : "${str}Cn_$i,";
+ }
+ }else {
+ $str="CLASS_SETTING={V{1\'b1}}\n";
+ }
+ #add_text_to_string (\$param_h,"\t#define $str");
+
+ my $v=$mpsoc->object_get_attribute('noc_param',"V")-1;
+ my $escape=$mpsoc->object_get_attribute('noc_param',"ESCAP_VC_MASK");
+ if (! defined $escape){
+ #add_text_to_string (\$param_h,"\tlocalparam [$v :0] ESCAP_VC_MASK=1;\n");
+ #add_text_to_string (\$pass_param,".ESCAP_VC_MASK(ESCAP_VC_MASK),\n");
+ }
+ #add_text_to_string (\$param_h," \tlocalparam CVw=(C==0)? V : C * V;\n");
+ #add_text_to_string (\$pass_param,".CVw(CVw)\n");
+
+ #remove 'b and 'h
+ #$param_h =~ s/\d\'b/ /g;
+ #$param_h =~ s/\'h/ /g;
+
+
+ return $param_h;
+}
+
+
+
+
+sub get_model_parameter {
+ my $model =shift;
+ my $o;
+ $o= do $model;
+ my %new_param=%{$o};
+ die "Error reading: $@" if $@;
+ my %temp;
+ foreach my $p (@params){
+ $temp{$p} = $default_noc_param{$p};
+ }
+ foreach my $p (sort keys %new_param){
+ $temp{$p} = $new_param{$p};
+ }
+ return %temp;
+}
+
+sub gen_noc_localparam_v {
+ my ($m,$ref) = @_;
+ my %model = %{$ref};
+ my %temp;
+
+
+ foreach my $p (@params){
+ $temp{$p} = $default_noc_param{$p};
+ $m->{noc_param}{$p}=$default_noc_param{$p};
+ }
+ foreach my $p (sort keys %model){
+ $temp{$p} = $model{$p};
+ $m->{noc_param}{$p}=$model{$p};
+ }
+
+ object_add_attribute_order($m,'noc_param',@params);
+
+ my $param_v="`ifdef NOC_LOCAL_PARAM \n";
+ foreach my $p (@params){
+ $param_v.="localparam $p = $temp{$p};\n";
+ }
+ $param_v.="`endif\n";
+
+ my ($nr,$ne,$router_p,$ref_tops,$includ_h) = get_noc_verilator_top_modules_info($m);
+ my %tops = %{$ref_tops};
+ $tops{Vtraffic} = "--top-module traffic_gen_top";
+ $tops{Vpck_inj} = "--top-module packet_injector_verilator";
+
+
+
+
+ my $param_h=gen_noc_param_h($m);
+ $includ_h = gen_sim_parameter_h($param_h,$includ_h,$ne,$nr,$router_p,'16');
+
+ return ($param_v,$includ_h,\%tops);
+
+}
+
+
+sub copy_src_files{
+
+ if(defined $ENV{PRONOC_WORK}){
+ rmtree("$rtl_dir");
+ unless (-d "$rtl_dir"){
+ print "make a working directory inside $rtl_dir\n";
+ mkdir("$rtl_dir", 0700);
+
+ }
+ }else{
+ print "Please set PRONOC_WORK variable first!";
+ exit;
+ }
+
+ dircopy("$root/rtl/src_noc" , "$rtl_dir/src_noc" ) or die("$!\n") unless (-d "$rtl_dir/src_noc" );
+ dircopy("$root/rtl/src_topolgy", "$rtl_dir/src_topolgy") or die("$!\n") unless (-d "$rtl_dir/src_topolgy");
+
+ unlink "$rtl_dir/src_noc/noc_localparam.v";
+ for my $file (glob "$root/rtl/*.v") {
+ copy $file, "$rtl_dir" or die $! ;
+ }
+
+
+
+}
+
+
+
+
+sub gen_file_list{
+ my $path=shift;
+ my $f="+incdir+$rtl_dir/
++incdir+$rtl_dir/src_noc/
++incdir+$path
+";
+
+ my @files = File::Find::Rule->file()
+ ->name( '*.v','*.V','*.sv' )
+ ->in( "$rtl_dir" );
+
+ #make sure source files have key word 'module'
+ my @sources;
+ foreach my $p (@files){
+ push (@sources,$p) if(check_file_has_string($p,'endpackage'));
+ }
+ foreach my $p (@files){
+ push (@sources,$p) if(check_file_has_string($p,'module'));
+ }
+ my $files = join ("\n",@sources);
+ $f.=$files;
+
+
+ open(FILE, ">$path/file_list.f") || die "Can not open: $!";
+ print FILE $f;
+ close FILE;
+}
+
+
+
+sub gen_models {
+ my @models = glob("$dirname/models/*");
+ mkdir("$work", 0700);
+ foreach my $m (@models){
+ print "$m\n";
+ #make noc localparam
+ my $o;
+ $o= do $m;
+ die "Error reading: $@" if $@;
+ my $param = $o->{'noc_param'};
+ my ($fname,$fpath,$fsuffix) = fileparse("$m",qr"\..[^.]*$");
+
+
+ my $name = $fname;
+ my $make =$o->{'makefile'};
+
+
+ my ($param_v,$include_h,$tops)= gen_noc_localparam_v( $o,$param);
+
+ mkdir("$work/$name", 0700);
+ save_file("$work/$name/noc_localparam.v",$param_v);
+
+ #generate file list
+ gen_file_list("$work/$name");
+
+
+
+
+ }
+
+}
+
+
+
+
+
+
+sub compile_models{
+ my($self,$inref)=@_;
+ my ($paralel_run,$MIN,$MAX,$STEP) = @{$inref};
+ my @models = glob("$dirname/models/*");
+ #generate compile command
+ my $i=0;
+ my $cmd;
+ foreach my $m (@models){
+ my ($fname,$fpath,$fsuffix) = fileparse("$m",qr"\..[^.]*$");
+ $cmd.=" cd $work/$fname; bash verilator.sh > $work/$fname/out.log 2>&1 &\n";
+ $i++;
+ $cmd.="wait\n" if(($i % $paralel_run)==0) ;
+ }
+ $cmd.="wait\n" if(($i % $paralel_run)!=0) ;
+ #run command in terminal
+ print "*******************compile models******************\n$cmd\n";
+ my $proc1 = Proc::Background->new($cmd);
+ $proc1->alive;
+ $proc1->wait;
+ $proc1->die;
+
+}
+
+
+
+
+
+
+sub check_compilation_log {
+ my ($name,$ref,$inref) = @_;
+ my @log_report_match =@{$ref};
+ my ($paralel_run,$MIN,$MAX,$STEP) = @{$inref};
+ my $logfile = "$work/$name/out.log";
+
+ my @found;
+ foreach my $m (@log_report_match){
+ open my $INPUT, '<', $logfile;
+ push(@found , grep ( /$m/, <$INPUT>)) ;
+ close($INPUT);
+ }
+
+ foreach my $line (@found) {
+ append_text_to_file($report,"\t $line\n");
+ }
+}
+
+
+
+
+
+sub check_compilation {
+ my ($self,$ref1,$ref2)=@_;
+ my @models = glob("$dirname/models/*");
+ foreach my $m (@models){
+ my ($name,$fpath,$fsuffix) = fileparse("$m",qr"\..[^.]*$");
+ append_text_to_file($report,"****************************$name : Compile *******************************:\n");
+ #check if testbench is generated successfully
+ if(-f "$work/$name/obj_dir/testbench"){
+ append_text_to_file($report,"\t model is generated successfully.\n");
+ check_compilation_log($name,$ref1,$ref2);
+
+ }else{
+ append_text_to_file($report,"\t model generation is FAILED.\n");
+ check_compilation_log($name,$ref1,$ref2);
+ }
+
+ }
+}
+
+
+sub run_all_models {
+ my ($self,$inref) =@_;
+ my ($paralel_run,$MIN,$MAX,$STEP) = @{$inref};
+ my @models = glob("$dirname/models/*");
+ foreach my $m (@models){
+ run_traffic ($self,$m,'random',$inref);
+ }
+ foreach my $m (@models){
+ run_traffic ($self,$m,'transposed 1',$inref);
+ }
+}
+
+
+
+sub run_traffic {
+ my ($self,$model,$traffic,$inref)=@_;
+ my ($paralel_run,$MIN,$MAX,$STEP) = @{$inref};
+ my ($name,$fpath,$fsuffix) = fileparse("$model",qr"\..[^.]*$");
+
+ my %param = get_model_parameter($model);
+ my $min_pck = $param{'MIN_PCK_SIZE'};
+
+ append_text_to_file($report,"****************************$name : $traffic traffic *******************************:\n");
+ unless (-f "$work/$name/obj_dir/testbench"){
+ append_text_to_file($report,"\t failed. Simulation model is not avaialable\n");
+ return;
+ }
+
+
+
+ my $file_name="${traffic}_results";
+ $file_name =~ s/\s+//g;
+
+ mkdir("$work/$name/$file_name/", 0700);
+
+ my $i=0;
+ my $cmd;
+
+
+ for (my $inject=$MIN; $inject<=$MAX; $inject+=$STEP){
+ $cmd.="$work/$name/obj_dir/testbench -t \"$traffic\" -m \"R,$min_pck,10\" -n 20000 -c 10000 -i $inject -p \"100,0,0,0,0\" > $work/$name/$file_name/sim$inject 2>&1 &\n";
+ $i++;
+ $cmd.="wait\n" if(($i % $paralel_run)==0) ;
+ }
+ $cmd.="wait\n" if(($i % $paralel_run)!=0) ;
+ #run command in terminal
+ print "*******************run models******************\n$cmd\n";
+ my $proc1 = Proc::Background->new($cmd);
+ $proc1->alive;
+ $proc1->wait;
+ $proc1->die;
+
+ check_sim_results($self,$name,$traffic,$inref);
+
+}
+
+
+sub extract_result {
+ my ($self,$file,$filed)=@_;
+
+ my @r = unix_grep($file,$filed);
+ my $string = $r[0];
+ $string =~ s/[^0-9.]+//g;
+ return $string;
+
+}
+
+sub get_zero_load_and_saturation{
+ my ($self,$name,$traffic,$path)=@_;
+ my %results;
+ my $ref = $self->{'name'}{"$name"}{'traffic'}{$traffic}{"packet_latency"};
+ return if !defined $ref;
+ %results = %{$ref};
+
+ my $zero_latency=9999999;
+ my $saturat_inject=100;
+ my $zero_inject;
+ my $saturat_latency='-';
+
+ my $txt = "#name:$name\n";
+
+ foreach my $inj (sort {$a <=> $b} keys %results){
+ $txt.="$inj $results{$inj}\n";
+ if ($zero_latency > $results{$inj}) {
+ $zero_latency = $results{$inj};
+ $zero_inject = $inj;
+ }
+ }
+ # assum saturation happens when the latency is 5 times of zero load
+ foreach my $inj (sort {$a <=> $b} keys %results){
+ if($results{$inj} >= 5 * $zero_latency ) {
+ if($saturat_inject > $inj){
+ $saturat_inject =$inj;
+ $saturat_latency=$results{$inj};
+ }
+ }
+ }
+ $txt.="\n";
+ save_file("$path/packet_latency.sv",$txt);
+
+
+ return ($zero_inject,$zero_latency, $saturat_inject,$saturat_latency);
+}
+
+
+
+
+sub check_sim_results{
+ my ($self,$name,$traffic,$inref)=@_;
+ my ($paralel_run,$MIN,$MAX,$STEP) = @{$inref};
+ my $file_name="${traffic}_results";
+ $file_name =~ s/\s+//g;
+ my $results_path = "$work/$name/$file_name";
+
+ #my @results = glob("$results_path/*");
+ #check for error
+
+ for (my $inject=$MIN; $inject<=$MAX; $inject+=$STEP){
+ my $file = "$results_path/sim$inject";
+
+ my @errors = unix_grep("$file","ERROR:");
+ if (scalar @errors ){
+ append_text_to_file($report,"\t Error in running simulation: @errors \n");
+ $self->{'name'}{"$name"}{'traffic'}{$traffic}{'overal_result'}="Failed";
+ $self->{'name'}{"$name"}{'traffic'}{$traffic}{'message'}="@errors";
+ return;
+ }
+ my @r = unix_grep($file,"total,");
+ my $string = $r[0];
+ my @fileds=split(',',$string);
+ my $val=$fileds[11];
+ $val =~ s/[^0-9.]+//g;
+ # my $val = extract_result($self,$file,"average packet latency");
+ if(length $val ==0){
+ $self->{'name'}{"$name"}{'traffic'}{$traffic}{'overal_result'}="Failed";
+ $self->{'name'}{"$name"}{'traffic'}{$traffic}{'message'}="The average packet latency is undefined for $inject";
+ return;
+ }
+ $self->{'name'}{"$name"}{'traffic'}{$traffic}{"packet_latency"}{$inject}="$val";
+
+ }
+ my ($z,$zl, $s,$sl) = get_zero_load_and_saturation ($self,$name,$traffic,$results_path);
+ print "($z,$zl, $s,$sl)\n";
+
+ #save results in a text file
+
+
+
+ append_text_to_file($report,"\t Passed: zero load ($z,$zl) saturation ($s,$sl)\n");
+ $self->{'name'}{"$name"}{'traffic'}{$traffic}{'overal_result'}="passed";
+}
+
FPGA-kc07/src/src.pl
Property changes :
Added: svn:executable
## -0,0 +1 ##
+*
\ No newline at end of property
Index: synthetic_sim/failed-model/line2_2cycle_mcast_f
===================================================================
--- synthetic_sim/failed-model/line2_2cycle_mcast_f (nonexistent)
+++ synthetic_sim/failed-model/line2_2cycle_mcast_f (revision 56)
@@ -0,0 +1,12 @@
+$model = bless( {
+
+ 'noc_param'=> {
+ TOPOLOGY=>"\"LINE\"",
+ "T1" => "4",
+ "T2" => "4",
+ "CAST_TYPE" => "\"MULTICAST_FULL\"",
+ "Fpay" => "64",
+ "MCAST_ENDP_LIST" => "'b11",
+
+ }
+}, 'ProNOC' );
Index: synthetic_sim/line/Line_3x2_v2
===================================================================
--- synthetic_sim/line/Line_3x2_v2 (nonexistent)
+++ synthetic_sim/line/Line_3x2_v2 (revision 56)
@@ -0,0 +1,18 @@
+$model = bless( {
+
+ 'noc_param'=> {
+ "TOPOLOGY" => "\"LINE\"",
+ "T1" => "3",
+ "T2" => "1",
+ "T3" => "4",
+ "V" => "2",
+ "B" => "4",
+ "LB" => "4",
+ "Fpay" => "32",
+ "ROUTE_NAME"=>"\"XY\""
+
+ }
+}, 'ProNOC' );
+
+
+
Index: synthetic_sim/line/line2_openpiton
===================================================================
--- synthetic_sim/line/line2_openpiton (nonexistent)
+++ synthetic_sim/line/line2_openpiton (revision 56)
@@ -0,0 +1,14 @@
+$model = bless( {
+ 'noc_param'=> {
+ TOPOLOGY=>"\"LINE\"",
+ "T1" => "2",
+ "V" => "1",
+ "ESCAP_VC_MASK" => "1'b1",
+ "B" => "4",
+ "LB" => "16",
+ "Fpay" => "64",
+ "SSA_EN" => "\"YES\"",
+ "SELF_LOOP_EN" => "\"YES\"",
+ "MCAST_ENDP_LIST" => "'b11",
+ }
+}, 'ProNOC' );
Index: synthetic_sim/line/line4_smart3
===================================================================
--- synthetic_sim/line/line4_smart3 (nonexistent)
+++ synthetic_sim/line/line4_smart3 (revision 56)
@@ -0,0 +1,16 @@
+$model = bless( {
+ 'noc_param'=> {
+ "SMART_MAX" => "3",
+ TOPOLOGY=>"\"LINE\"",
+ "T1" => "4",
+ "T2" => "4",
+ "V" => "1",
+ "ESCAP_VC_MASK" => "1'b1",
+ "B" => "4",
+ "LB" => "16",
+ "Fpay" => "64",
+ "SSA_EN" => "\"NO\"",
+ "SELF_LOOP_EN" => "\"YES\"",
+ "MCAST_ENDP_LIST" => "'b11",
+ }
+}, 'ProNOC' );
Index: synthetic_sim/line/line_4_v1_B15
===================================================================
--- synthetic_sim/line/line_4_v1_B15 (nonexistent)
+++ synthetic_sim/line/line_4_v1_B15 (revision 56)
@@ -0,0 +1,21 @@
+$model = bless( {
+ 'noc_param'=> {
+ TOPOLOGY=>"\"LINE\"",
+ "T1" => "4",
+ "T2" => "4",
+ "V" => "1",
+ "ESCAP_VC_MASK" => "1'b1",
+ "B" => "15",
+ "LB" => "15",
+ "Fpay" => "64",
+ "SSA_EN" => "\"NO\"",
+ "SELF_LOOP_EN" => "\"NO\"",
+ }
+}, 'ProNOC' );
+
+
+
+
+
+
+
Index: synthetic_sim/line/line_4x3_2cycle_xy
===================================================================
--- synthetic_sim/line/line_4x3_2cycle_xy (nonexistent)
+++ synthetic_sim/line/line_4x3_2cycle_xy (revision 56)
@@ -0,0 +1,10 @@
+$model = bless( {
+ 'compile' => "verilate_mesh.sh",
+ 'noc_param'=> {
+ TOPOLOGY=>"\"LINE\"",
+ "T1" => "4",
+ "T2" => "4",
+ "T3" => "3",
+ "ROUTE_NAME" => "\"XY\"",
+ }
+}, 'ProNOC' );
Index: synthetic_sim/line/line_8_2cycle_xy
===================================================================
--- synthetic_sim/line/line_8_2cycle_xy (nonexistent)
+++ synthetic_sim/line/line_8_2cycle_xy (revision 56)
@@ -0,0 +1,6 @@
+$model = bless( {
+ 'noc_param'=> {
+ TOPOLOGY=>"\"LINE\"",
+ "ROUTE_NAME" => "\"XY\"",
+ }
+}, 'ProNOC' );
Index: synthetic_sim/line/line_8_b2
===================================================================
--- synthetic_sim/line/line_8_b2 (nonexistent)
+++ synthetic_sim/line/line_8_b2 (revision 56)
@@ -0,0 +1,8 @@
+$model = bless( {
+ 'noc_param'=> {
+ TOPOLOGY=>"\"LINE\"",
+ "ROUTE_NAME" => "\"XY\"",
+ "B"=> "2",
+ "LB"=> 2
+ }
+}, 'ProNOC' );
Index: synthetic_sim/line/line_8_sbp6_xy
===================================================================
--- synthetic_sim/line/line_8_sbp6_xy (nonexistent)
+++ synthetic_sim/line/line_8_sbp6_xy (revision 56)
@@ -0,0 +1,6 @@
+$model = bless( {
+ 'noc_param'=> {
+ TOPOLOGY=>"\"LINE\"",
+ "SMART_MAX" => "6",
+ }
+}, 'ProNOC' );
Index: synthetic_sim/line/line_8_single_flit
===================================================================
--- synthetic_sim/line/line_8_single_flit (nonexistent)
+++ synthetic_sim/line/line_8_single_flit (revision 56)
@@ -0,0 +1,10 @@
+$model = bless( {
+
+ 'noc_param'=> {
+TOPOLOGY=>"\"LINE\"",
+ "B" => "5",
+ "LB" => "5",
+ "MIN_PCK_SIZE" => "1",
+ "PCK_TYPE" => " \"SINGLE_FLIT\"",
+ }
+}, 'ProNOC' );
Index: synthetic_sim/line/line_8x8_ssa_xy
===================================================================
--- synthetic_sim/line/line_8x8_ssa_xy (nonexistent)
+++ synthetic_sim/line/line_8x8_ssa_xy (revision 56)
@@ -0,0 +1,6 @@
+$model = bless( {
+ 'noc_param'=> {
+ TOPOLOGY=>"\"LINE\"",
+ "SSA_EN" => "\"YES\"",
+ }
+}, 'ProNOC' );
Index: synthetic_sim/line/linex8_4vc_4c
===================================================================
--- synthetic_sim/line/linex8_4vc_4c (nonexistent)
+++ synthetic_sim/line/linex8_4vc_4c (revision 56)
@@ -0,0 +1,10 @@
+$model = bless( {
+ 'noc_param'=> {
+ TOPOLOGY=>"\"LINE\"",
+ "ROUTE_NAME" => "\"XY\"",
+ "V" => 4,
+ "C" => 4,
+ "CLASS_SETTING" => "16'b1000010000100001",
+ "ESCAP_VC_MASK" => "4'b1000"
+ }
+}, 'ProNOC' );
Index: synthetic_sim/line/ring_8x8_2cycle_xy
===================================================================
--- synthetic_sim/line/ring_8x8_2cycle_xy (nonexistent)
+++ synthetic_sim/line/ring_8x8_2cycle_xy (revision 56)
@@ -0,0 +1,8 @@
+$model = bless( {
+ 'compile' => "verilate_mesh.sh",
+ 'noc_param'=> {
+ TOPOLOGY=>"\"RING\"",
+ "TOPOLOGY" => "\"TORUS\"",
+ "ROUTE_NAME" => "\"TRANC_XY\"",
+ }
+}, 'ProNOC' );
Index: synthetic_sim/models/mesh_4x4_smart3
===================================================================
--- synthetic_sim/models/mesh_4x4_smart3 (nonexistent)
+++ synthetic_sim/models/mesh_4x4_smart3 (revision 56)
@@ -0,0 +1,15 @@
+$model = bless( {
+ 'noc_param'=> {
+ "SMART_MAX" => "3",
+ "TOPOLOGY"=> "\"FMESH\"",
+ "T1" => "4",
+ "T2" => "4",
+ "V" => "1",
+ "ESCAP_VC_MASK" => "1'b1",
+ "B" => "4",
+ "LB" => "16",
+ "Fpay" => "64",
+ "SSA_EN" => "\"NO\"",
+ "SELF_LOOP_EN" => "\"YES\"",
+ }
+}, 'ProNOC' );
Index: synthetic_sim/perl_lib/Class/Accessor/Fast.pm
===================================================================
--- synthetic_sim/perl_lib/Class/Accessor/Fast.pm (nonexistent)
+++ synthetic_sim/perl_lib/Class/Accessor/Fast.pm (revision 56)
@@ -0,0 +1,97 @@
+package Class::Accessor::Fast;
+use base 'Class::Accessor';
+use strict;
+use B 'perlstring';
+$Class::Accessor::Fast::VERSION = '0.51';
+
+sub make_accessor {
+ my ($class, $field) = @_;
+
+ eval sprintf q{
+ sub {
+ return $_[0]{%s} if scalar(@_) == 1;
+ return $_[0]{%s} = scalar(@_) == 2 ? $_[1] : [@_[1..$#_]];
+ }
+ }, map { perlstring($_) } $field, $field;
+}
+
+sub make_ro_accessor {
+ my($class, $field) = @_;
+
+ eval sprintf q{
+ sub {
+ return $_[0]{%s} if @_ == 1;
+ my $caller = caller;
+ $_[0]->_croak(sprintf "'$caller' cannot alter the value of '%%s' on objects of class '%%s'", %s, %s);
+ }
+ }, map { perlstring($_) } $field, $field, $class;
+}
+
+sub make_wo_accessor {
+ my($class, $field) = @_;
+
+ eval sprintf q{
+ sub {
+ if (@_ == 1) {
+ my $caller = caller;
+ $_[0]->_croak(sprintf "'$caller' cannot access the value of '%%s' on objects of class '%%s'", %s, %s);
+ }
+ else {
+ return $_[0]{%s} = $_[1] if @_ == 2;
+ return (shift)->{%s} = \@_;
+ }
+ }
+ }, map { perlstring($_) } $field, $class, $field, $field;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Class::Accessor::Fast - Faster, but less expandable, accessors
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use base qw(Class::Accessor::Fast);
+
+ # The rest is the same as Class::Accessor but without set() and get().
+
+=head1 DESCRIPTION
+
+This is a faster but less expandable version of Class::Accessor.
+Class::Accessor's generated accessors require two method calls to accomplish
+their task (one for the accessor, another for get() or set()).
+Class::Accessor::Fast eliminates calling set()/get() and does the access itself,
+resulting in a somewhat faster accessor.
+
+The downside is that you can't easily alter the behavior of your
+accessors, nor can your subclasses. Of course, should you need this
+later, you can always swap out Class::Accessor::Fast for
+Class::Accessor.
+
+Read the documentation for Class::Accessor for more info.
+
+=head1 EFFICIENCY
+
+L for an efficiency comparison.
+
+=head1 AUTHORS
+
+Copyright 2017 Marty Pauley
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself. That means either (a) the GNU General Public
+License or (b) the Artistic License.
+
+=head2 ORIGINAL AUTHOR
+
+Michael G Schwern
+
+=head1 SEE ALSO
+
+L
+
+=cut
Index: synthetic_sim/perl_lib/Class/Accessor/Faster.pm
===================================================================
--- synthetic_sim/perl_lib/Class/Accessor/Faster.pm (nonexistent)
+++ synthetic_sim/perl_lib/Class/Accessor/Faster.pm (revision 56)
@@ -0,0 +1,109 @@
+package Class::Accessor::Faster;
+use base 'Class::Accessor';
+use strict;
+use B 'perlstring';
+$Class::Accessor::Faster::VERSION = '0.51';
+
+my %slot;
+sub _slot {
+ my($class, $field) = @_;
+ my $n = $slot{$class}->{$field};
+ return $n if defined $n;
+ $n = keys %{$slot{$class}};
+ $slot{$class}->{$field} = $n;
+ return $n;
+}
+
+sub new {
+ my($proto, $fields) = @_;
+ my($class) = ref $proto || $proto;
+ my $self = bless [], $class;
+
+ $fields = {} unless defined $fields;
+ for my $k (keys %$fields) {
+ my $n = $class->_slot($k);
+ $self->[$n] = $fields->{$k};
+ }
+ return $self;
+}
+
+sub make_accessor {
+ my($class, $field) = @_;
+ my $n = $class->_slot($field);
+ eval sprintf q{
+ sub {
+ return $_[0][%d] if scalar(@_) == 1;
+ return $_[0][%d] = scalar(@_) == 2 ? $_[1] : [@_[1..$#_]];
+ }
+ }, $n, $n;
+}
+
+sub make_ro_accessor {
+ my($class, $field) = @_;
+ my $n = $class->_slot($field);
+ eval sprintf q{
+ sub {
+ return $_[0][%d] if @_ == 1;
+ my $caller = caller;
+ $_[0]->_croak(sprintf "'$caller' cannot alter the value of '%%s' on objects of class '%%s'", %s, %s);
+ }
+ }, $n, map(perlstring($_), $field, $class);
+}
+
+sub make_wo_accessor {
+ my($class, $field) = @_;
+ my $n = $class->_slot($field);
+ eval sprintf q{
+ sub {
+ if (@_ == 1) {
+ my $caller = caller;
+ $_[0]->_croak(sprintf "'$caller' cannot access the value of '%%s' on objects of class '%%s'", %s, %s);
+ }
+ else {
+ return $_[0][%d] = $_[1] if @_ == 2;
+ return (shift)->[%d] = \@_;
+ }
+ }
+ }, map(perlstring($_), $field, $class), $n, $n;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Class::Accessor::Faster - Even faster, but less expandable, accessors
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use base qw(Class::Accessor::Faster);
+
+=head1 DESCRIPTION
+
+This is a faster but less expandable version of Class::Accessor::Fast.
+
+Class::Accessor's generated accessors require two method calls to accomplish
+their task (one for the accessor, another for get() or set()).
+
+Class::Accessor::Fast eliminates calling set()/get() and does the access itself,
+resulting in a somewhat faster accessor.
+
+Class::Accessor::Faster uses an array reference underneath to be faster.
+
+Read the documentation for Class::Accessor for more info.
+
+=head1 AUTHORS
+
+Copyright 2017 Marty Pauley
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself. That means either (a) the GNU General Public
+License or (b) the Artistic License.
+
+=head1 SEE ALSO
+
+L
+
+=cut
Index: synthetic_sim/perl_lib/Class/Accessor.pm
===================================================================
--- synthetic_sim/perl_lib/Class/Accessor.pm (nonexistent)
+++ synthetic_sim/perl_lib/Class/Accessor.pm (revision 56)
@@ -0,0 +1,742 @@
+package Class::Accessor;
+require 5.00502;
+use strict;
+$Class::Accessor::VERSION = '0.51';
+
+sub new {
+ return bless
+ defined $_[1]
+ ? {%{$_[1]}} # make a copy of $fields.
+ : {},
+ ref $_[0] || $_[0];
+}
+
+sub mk_accessors {
+ my($self, @fields) = @_;
+
+ $self->_mk_accessors('rw', @fields);
+}
+
+if (eval { require Sub::Name }) {
+ Sub::Name->import;
+}
+
+{
+ no strict 'refs';
+
+ sub import {
+ my ($class, @what) = @_;
+ my $caller = caller;
+ for (@what) {
+ if (/^(?:antlers|moose-?like)$/i) {
+ *{"${caller}::has"} = sub {
+ my ($f, %args) = @_;
+ $caller->_mk_accessors(($args{is}||"rw"), $f);
+ };
+ *{"${caller}::extends"} = sub {
+ @{"${caller}::ISA"} = @_;
+ unless (grep $_->can("_mk_accessors"), @_) {
+ push @{"${caller}::ISA"}, $class;
+ }
+ };
+ # we'll use their @ISA as a default, in case it happens to be
+ # set already
+ &{"${caller}::extends"}(@{"${caller}::ISA"});
+ }
+ }
+ }
+
+ sub follow_best_practice {
+ my($self) = @_;
+ my $class = ref $self || $self;
+ *{"${class}::accessor_name_for"} = \&best_practice_accessor_name_for;
+ *{"${class}::mutator_name_for"} = \&best_practice_mutator_name_for;
+ }
+
+ sub _mk_accessors {
+ my($self, $access, @fields) = @_;
+ my $class = ref $self || $self;
+ my $ra = $access eq 'rw' || $access eq 'ro';
+ my $wa = $access eq 'rw' || $access eq 'wo';
+
+ foreach my $field (@fields) {
+ my $accessor_name = $self->accessor_name_for($field);
+ my $mutator_name = $self->mutator_name_for($field);
+ if( $accessor_name eq 'DESTROY' or $mutator_name eq 'DESTROY' ) {
+ $self->_carp("Having a data accessor named DESTROY in '$class' is unwise.");
+ }
+ if ($accessor_name eq $mutator_name) {
+ my $accessor;
+ if ($ra && $wa) {
+ $accessor = $self->make_accessor($field);
+ } elsif ($ra) {
+ $accessor = $self->make_ro_accessor($field);
+ } else {
+ $accessor = $self->make_wo_accessor($field);
+ }
+ my $fullname = "${class}::$accessor_name";
+ my $subnamed = 0;
+ unless (defined &{$fullname}) {
+ subname($fullname, $accessor) if defined &subname;
+ $subnamed = 1;
+ *{$fullname} = $accessor;
+ }
+ if ($accessor_name eq $field) {
+ # the old behaviour
+ my $alias = "${class}::_${field}_accessor";
+ subname($alias, $accessor) if defined &subname and not $subnamed;
+ *{$alias} = $accessor unless defined &{$alias};
+ }
+ } else {
+ my $fullaccname = "${class}::$accessor_name";
+ my $fullmutname = "${class}::$mutator_name";
+ if ($ra and not defined &{$fullaccname}) {
+ my $accessor = $self->make_ro_accessor($field);
+ subname($fullaccname, $accessor) if defined &subname;
+ *{$fullaccname} = $accessor;
+ }
+ if ($wa and not defined &{$fullmutname}) {
+ my $mutator = $self->make_wo_accessor($field);
+ subname($fullmutname, $mutator) if defined &subname;
+ *{$fullmutname} = $mutator;
+ }
+ }
+ }
+ }
+
+}
+
+sub mk_ro_accessors {
+ my($self, @fields) = @_;
+
+ $self->_mk_accessors('ro', @fields);
+}
+
+sub mk_wo_accessors {
+ my($self, @fields) = @_;
+
+ $self->_mk_accessors('wo', @fields);
+}
+
+sub best_practice_accessor_name_for {
+ my ($class, $field) = @_;
+ return "get_$field";
+}
+
+sub best_practice_mutator_name_for {
+ my ($class, $field) = @_;
+ return "set_$field";
+}
+
+sub accessor_name_for {
+ my ($class, $field) = @_;
+ return $field;
+}
+
+sub mutator_name_for {
+ my ($class, $field) = @_;
+ return $field;
+}
+
+sub set {
+ my($self, $key) = splice(@_, 0, 2);
+
+ if(@_ == 1) {
+ $self->{$key} = $_[0];
+ }
+ elsif(@_ > 1) {
+ $self->{$key} = [@_];
+ }
+ else {
+ $self->_croak("Wrong number of arguments received");
+ }
+}
+
+sub get {
+ my $self = shift;
+
+ if(@_ == 1) {
+ return $self->{$_[0]};
+ }
+ elsif( @_ > 1 ) {
+ return @{$self}{@_};
+ }
+ else {
+ $self->_croak("Wrong number of arguments received");
+ }
+}
+
+sub make_accessor {
+ my ($class, $field) = @_;
+
+ return sub {
+ my $self = shift;
+
+ if(@_) {
+ return $self->set($field, @_);
+ } else {
+ return $self->get($field);
+ }
+ };
+}
+
+sub make_ro_accessor {
+ my($class, $field) = @_;
+
+ return sub {
+ my $self = shift;
+
+ if (@_) {
+ my $caller = caller;
+ $self->_croak("'$caller' cannot alter the value of '$field' on objects of class '$class'");
+ }
+ else {
+ return $self->get($field);
+ }
+ };
+}
+
+sub make_wo_accessor {
+ my($class, $field) = @_;
+
+ return sub {
+ my $self = shift;
+
+ unless (@_) {
+ my $caller = caller;
+ $self->_croak("'$caller' cannot access the value of '$field' on objects of class '$class'");
+ }
+ else {
+ return $self->set($field, @_);
+ }
+ };
+}
+
+
+use Carp ();
+
+sub _carp {
+ my ($self, $msg) = @_;
+ Carp::carp($msg || $self);
+ return;
+}
+
+sub _croak {
+ my ($self, $msg) = @_;
+ Carp::croak($msg || $self);
+ return;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ Class::Accessor - Automated accessor generation
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use base qw(Class::Accessor);
+ Foo->follow_best_practice;
+ Foo->mk_accessors(qw(name role salary));
+
+ # or if you prefer a Moose-like interface...
+
+ package Foo;
+ use Class::Accessor "antlers";
+ has name => ( is => "rw", isa => "Str" );
+ has role => ( is => "rw", isa => "Str" );
+ has salary => ( is => "rw", isa => "Num" );
+
+ # Meanwhile, in a nearby piece of code!
+ # Class::Accessor provides new().
+ my $mp = Foo->new({ name => "Marty", role => "JAPH" });
+
+ my $job = $mp->role; # gets $mp->{role}
+ $mp->salary(400000); # sets $mp->{salary} = 400000 # I wish
+
+ # like my @info = @{$mp}{qw(name role)}
+ my @info = $mp->get(qw(name role));
+
+ # $mp->{salary} = 400000
+ $mp->set('salary', 400000);
+
+
+=head1 DESCRIPTION
+
+This module automagically generates accessors/mutators for your class.
+
+Most of the time, writing accessors is an exercise in cutting and
+pasting. You usually wind up with a series of methods like this:
+
+ sub name {
+ my $self = shift;
+ if(@_) {
+ $self->{name} = $_[0];
+ }
+ return $self->{name};
+ }
+
+ sub salary {
+ my $self = shift;
+ if(@_) {
+ $self->{salary} = $_[0];
+ }
+ return $self->{salary};
+ }
+
+ # etc...
+
+One for each piece of data in your object. While some will be unique,
+doing value checks and special storage tricks, most will simply be
+exercises in repetition. Not only is it Bad Style to have a bunch of
+repetitious code, but it's also simply not lazy, which is the real
+tragedy.
+
+If you make your module a subclass of Class::Accessor and declare your
+accessor fields with mk_accessors() then you'll find yourself with a
+set of automatically generated accessors which can even be
+customized!
+
+The basic set up is very simple:
+
+ package Foo;
+ use base qw(Class::Accessor);
+ Foo->mk_accessors( qw(far bar car) );
+
+Done. Foo now has simple far(), bar() and car() accessors
+defined.
+
+Alternatively, if you want to follow Damian's I guidelines
+you can use:
+
+ package Foo;
+ use base qw(Class::Accessor);
+ Foo->follow_best_practice;
+ Foo->mk_accessors( qw(far bar car) );
+
+B you must call C before calling C.
+
+=head2 Moose-like
+
+By popular demand we now have a simple Moose-like interface. You can now do:
+
+ package Foo;
+ use Class::Accessor "antlers";
+ has far => ( is => "rw" );
+ has bar => ( is => "rw" );
+ has car => ( is => "rw" );
+
+Currently only the C attribute is supported.
+
+=head1 CONSTRUCTOR
+
+Class::Accessor provides a basic constructor, C. It generates a
+hash-based object and can be called as either a class method or an
+object method.
+
+=head2 new
+
+ my $obj = Foo->new;
+ my $obj = $other_obj->new;
+
+ my $obj = Foo->new(\%fields);
+ my $obj = $other_obj->new(\%fields);
+
+It takes an optional %fields hash which is used to initialize the
+object (handy if you use read-only accessors). The fields of the hash
+correspond to the names of your accessors, so...
+
+ package Foo;
+ use base qw(Class::Accessor);
+ Foo->mk_accessors('foo');
+
+ my $obj = Foo->new({ foo => 42 });
+ print $obj->foo; # 42
+
+however %fields can contain anything, new() will shove them all into
+your object.
+
+=head1 MAKING ACCESSORS
+
+=head2 follow_best_practice
+
+In Damian's Perl Best Practices book he recommends separate get and set methods
+with the prefix set_ and get_ to make it explicit what you intend to do. If you
+want to create those accessor methods instead of the default ones, call:
+
+ __PACKAGE__->follow_best_practice
+
+B you call any of the accessor-making methods.
+
+=head2 accessor_name_for / mutator_name_for
+
+You may have your own crazy ideas for the names of the accessors, so you can
+make those happen by overriding C and C in
+your subclass. (I copied that idea from Class::DBI.)
+
+=head2 mk_accessors
+
+ __PACKAGE__->mk_accessors(@fields);
+
+This creates accessor/mutator methods for each named field given in
+@fields. Foreach field in @fields it will generate two accessors.
+One called "field()" and the other called "_field_accessor()". For
+example:
+
+ # Generates foo(), _foo_accessor(), bar() and _bar_accessor().
+ __PACKAGE__->mk_accessors(qw(foo bar));
+
+See L
+for details.
+
+=head2 mk_ro_accessors
+
+ __PACKAGE__->mk_ro_accessors(@read_only_fields);
+
+Same as mk_accessors() except it will generate read-only accessors
+(ie. true accessors). If you attempt to set a value with these
+accessors it will throw an exception. It only uses get() and not
+set().
+
+ package Foo;
+ use base qw(Class::Accessor);
+ Foo->mk_ro_accessors(qw(foo bar));
+
+ # Let's assume we have an object $foo of class Foo...
+ print $foo->foo; # ok, prints whatever the value of $foo->{foo} is
+ $foo->foo(42); # BOOM! Naughty you.
+
+
+=head2 mk_wo_accessors
+
+ __PACKAGE__->mk_wo_accessors(@write_only_fields);
+
+Same as mk_accessors() except it will generate write-only accessors
+(ie. mutators). If you attempt to read a value with these accessors
+it will throw an exception. It only uses set() and not get().
+
+B I'm not entirely sure why this is useful, but I'm sure someone
+will need it. If you've found a use, let me know. Right now it's here
+for orthogonality and because it's easy to implement.
+
+ package Foo;
+ use base qw(Class::Accessor);
+ Foo->mk_wo_accessors(qw(foo bar));
+
+ # Let's assume we have an object $foo of class Foo...
+ $foo->foo(42); # OK. Sets $self->{foo} = 42
+ print $foo->foo; # BOOM! Can't read from this accessor.
+
+=head1 Moose!
+
+If you prefer a Moose-like interface to create accessors, you can use C by
+importing this module like this:
+
+ use Class::Accessor "antlers";
+
+or
+
+ use Class::Accessor "moose-like";
+
+Then you can declare accessors like this:
+
+ has alpha => ( is => "rw", isa => "Str" );
+ has beta => ( is => "ro", isa => "Str" );
+ has gamma => ( is => "wo", isa => "Str" );
+
+Currently only the C attribute is supported. And our C also supports
+the "wo" value to make a write-only accessor.
+
+If you are using the Moose-like interface then you should use the C
+rather than tweaking your C<@ISA> directly. Basically, replace
+
+ @ISA = qw/Foo Bar/;
+
+with
+
+ extends(qw/Foo Bar/);
+
+=head1 DETAILS
+
+An accessor generated by Class::Accessor looks something like
+this:
+
+ # Your foo may vary.
+ sub foo {
+ my($self) = shift;
+ if(@_) { # set
+ return $self->set('foo', @_);
+ }
+ else {
+ return $self->get('foo');
+ }
+ }
+
+Very simple. All it does is determine if you're wanting to set a
+value or get a value and calls the appropriate method.
+Class::Accessor provides default get() and set() methods which
+your class can override. They're detailed later.
+
+=head2 Modifying the behavior of the accessor
+
+Rather than actually modifying the accessor itself, it is much more
+sensible to simply override the two key methods which the accessor
+calls. Namely set() and get().
+
+If you -really- want to, you can override make_accessor().
+
+=head2 set
+
+ $obj->set($key, $value);
+ $obj->set($key, @values);
+
+set() defines how generally one stores data in the object.
+
+override this method to change how data is stored by your accessors.
+
+=head2 get
+
+ $value = $obj->get($key);
+ @values = $obj->get(@keys);
+
+get() defines how data is retrieved from your objects.
+
+override this method to change how it is retrieved.
+
+=head2 make_accessor
+
+ $accessor = __PACKAGE__->make_accessor($field);
+
+Generates a subroutine reference which acts as an accessor for the given
+$field. It calls get() and set().
+
+If you wish to change the behavior of your accessors, try overriding
+get() and set() before you start mucking with make_accessor().
+
+=head2 make_ro_accessor
+
+ $read_only_accessor = __PACKAGE__->make_ro_accessor($field);
+
+Generates a subroutine reference which acts as a read-only accessor for
+the given $field. It only calls get().
+
+Override get() to change the behavior of your accessors.
+
+=head2 make_wo_accessor
+
+ $write_only_accessor = __PACKAGE__->make_wo_accessor($field);
+
+Generates a subroutine reference which acts as a write-only accessor
+(mutator) for the given $field. It only calls set().
+
+Override set() to change the behavior of your accessors.
+
+=head1 EXCEPTIONS
+
+If something goes wrong Class::Accessor will warn or die by calling Carp::carp
+or Carp::croak. If you don't like this you can override _carp() and _croak() in
+your subclass and do whatever else you want.
+
+=head1 EFFICIENCY
+
+Class::Accessor does not employ an autoloader, thus it is much faster
+than you'd think. Its generated methods incur no special penalty over
+ones you'd write yourself.
+
+ accessors:
+ Rate Basic Fast Faster Direct
+ Basic 367589/s -- -51% -55% -89%
+ Fast 747964/s 103% -- -9% -77%
+ Faster 819199/s 123% 10% -- -75%
+ Direct 3245887/s 783% 334% 296% --
+
+ mutators:
+ Rate Acc Fast Faster Direct
+ Acc 265564/s -- -54% -63% -91%
+ Fast 573439/s 116% -- -21% -80%
+ Faster 724710/s 173% 26% -- -75%
+ Direct 2860979/s 977% 399% 295% --
+
+Class::Accessor::Fast is faster than methods written by an average programmer
+(where "average" is based on Schwern's example code).
+
+Class::Accessor is slower than average, but more flexible.
+
+Class::Accessor::Faster is even faster than Class::Accessor::Fast. It uses an
+array internally, not a hash. This could be a good or bad feature depending on
+your point of view.
+
+Direct hash access is, of course, much faster than all of these, but it
+provides no encapsulation.
+
+Of course, it's not as simple as saying "Class::Accessor is slower than
+average". These are benchmarks for a simple accessor. If your accessors do
+any sort of complicated work (such as talking to a database or writing to a
+file) the time spent doing that work will quickly swamp the time spend just
+calling the accessor. In that case, Class::Accessor and the ones you write
+will be roughly the same speed.
+
+
+=head1 EXAMPLES
+
+Here's an example of generating an accessor for every public field of
+your class.
+
+ package Altoids;
+
+ use base qw(Class::Accessor Class::Fields);
+ use fields qw(curiously strong mints);
+ Altoids->mk_accessors( Altoids->show_fields('Public') );
+
+ sub new {
+ my $proto = shift;
+ my $class = ref $proto || $proto;
+ return fields::new($class);
+ }
+
+ my Altoids $tin = Altoids->new;
+
+ $tin->curiously('Curiouser and curiouser');
+ print $tin->{curiously}; # prints 'Curiouser and curiouser'
+
+
+ # Subclassing works, too.
+ package Mint::Snuff;
+ use base qw(Altoids);
+
+ my Mint::Snuff $pouch = Mint::Snuff->new;
+ $pouch->strong('Blow your head off!');
+ print $pouch->{strong}; # prints 'Blow your head off!'
+
+
+Here's a simple example of altering the behavior of your accessors.
+
+ package Foo;
+ use base qw(Class::Accessor);
+ Foo->mk_accessors(qw(this that up down));
+
+ sub get {
+ my $self = shift;
+
+ # Note every time someone gets some data.
+ print STDERR "Getting @_\n";
+
+ $self->SUPER::get(@_);
+ }
+
+ sub set {
+ my ($self, $key) = splice(@_, 0, 2);
+
+ # Note every time someone sets some data.
+ print STDERR "Setting $key to @_\n";
+
+ $self->SUPER::set($key, @_);
+ }
+
+
+=head1 CAVEATS AND TRICKS
+
+Class::Accessor has to do some internal wackiness to get its
+job done quickly and efficiently. Because of this, there's a few
+tricks and traps one must know about.
+
+Hey, nothing's perfect.
+
+=head2 Don't make a field called DESTROY
+
+This is bad. Since DESTROY is a magical method it would be bad for us
+to define an accessor using that name. Class::Accessor will
+carp if you try to use it with a field named "DESTROY".
+
+=head2 Overriding autogenerated accessors
+
+You may want to override the autogenerated accessor with your own, yet
+have your custom accessor call the default one. For instance, maybe
+you want to have an accessor which checks its input. Normally, one
+would expect this to work:
+
+ package Foo;
+ use base qw(Class::Accessor);
+ Foo->mk_accessors(qw(email this that whatever));
+
+ # Only accept addresses which look valid.
+ sub email {
+ my($self) = shift;
+ my($email) = @_;
+
+ if( @_ ) { # Setting
+ require Email::Valid;
+ unless( Email::Valid->address($email) ) {
+ carp("$email doesn't look like a valid address.");
+ return;
+ }
+ }
+
+ return $self->SUPER::email(@_);
+ }
+
+There's a subtle problem in the last example, and it's in this line:
+
+ return $self->SUPER::email(@_);
+
+If we look at how Foo was defined, it called mk_accessors() which
+stuck email() right into Foo's namespace. There *is* no
+SUPER::email() to delegate to! Two ways around this... first is to
+make a "pure" base class for Foo. This pure class will generate the
+accessors and provide the necessary super class for Foo to use:
+
+ package Pure::Organic::Foo;
+ use base qw(Class::Accessor);
+ Pure::Organic::Foo->mk_accessors(qw(email this that whatever));
+
+ package Foo;
+ use base qw(Pure::Organic::Foo);
+
+And now Foo::email() can override the generated
+Pure::Organic::Foo::email() and use it as SUPER::email().
+
+This is probably the most obvious solution to everyone but me.
+Instead, what first made sense to me was for mk_accessors() to define
+an alias of email(), _email_accessor(). Using this solution,
+Foo::email() would be written with:
+
+ return $self->_email_accessor(@_);
+
+instead of the expected SUPER::email().
+
+
+=head1 AUTHORS
+
+Copyright 2017 Marty Pauley
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself. That means either (a) the GNU General Public
+License or (b) the Artistic License.
+
+=head2 ORIGINAL AUTHOR
+
+Michael G Schwern
+
+=head2 THANKS
+
+Liz and RUZ for performance tweaks.
+
+Tels, for his big feature request/bug report.
+
+Various presenters at YAPC::Asia 2009 for criticising the non-Moose interface.
+
+=head1 SEE ALSO
+
+See L and L if speed is more
+important than flexibility.
+
+These are some modules which do similar things in different ways
+L, L, L,
+L, L, L, L
+
+See L for an example of this module in use.
+
+=cut
Index: synthetic_sim/perl_lib/Exporter/Tiny.pm
===================================================================
--- synthetic_sim/perl_lib/Exporter/Tiny.pm (nonexistent)
+++ synthetic_sim/perl_lib/Exporter/Tiny.pm (revision 56)
@@ -0,0 +1,508 @@
+package Exporter::Tiny;
+
+use 5.006001;
+use strict;
+use warnings; no warnings qw(void once uninitialized numeric redefine);
+
+our $AUTHORITY = 'cpan:TOBYINK';
+our $VERSION = '1.002002';
+our @EXPORT_OK = qw< mkopt mkopt_hash _croak _carp >;
+
+sub _croak ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::croak }
+sub _carp ($;@) { require Carp; my $fmt = shift; @_ = sprintf($fmt, @_); goto \&Carp::carp }
+
+my $_process_optlist = sub
+{
+ my $class = shift;
+ my ($global_opts, $opts, $want, $not_want) = @_;
+
+ while (@$opts)
+ {
+ my $opt = shift @{$opts};
+ my ($name, $value) = @$opt;
+
+ ($name =~ m{\A\!(/.+/[msixpodual]*)\z}) ?
+ do {
+ my @not = $class->_exporter_expand_regexp($1, $value, $global_opts);
+ ++$not_want->{$_->[0]} for @not;
+ } :
+ ($name =~ m{\A\!(.+)\z}) ?
+ (++$not_want->{$1}) :
+ ($name =~ m{\A[:-](.+)\z}) ?
+ push(@$opts, $class->_exporter_expand_tag($1, $value, $global_opts)) :
+ ($name =~ m{\A/.+/[msixpodual]*\z}) ?
+ push(@$opts, $class->_exporter_expand_regexp($name, $value, $global_opts)) :
+ # else ?
+ push(@$want, $opt);
+ }
+};
+
+sub import
+{
+ my $class = shift;
+ my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () };
+ $global_opts->{into} = caller unless exists $global_opts->{into};
+
+ my @want;
+ my %not_want; $global_opts->{not} = \%not_want;
+ my @args = do { no strict qw(refs); @_ ? @_ : @{"$class\::EXPORT"} };
+ my $opts = mkopt(\@args);
+ $class->$_process_optlist($global_opts, $opts, \@want, \%not_want);
+
+ my $permitted = $class->_exporter_permitted_regexp($global_opts);
+ $class->_exporter_validate_opts($global_opts);
+
+ for my $wanted (@want)
+ {
+ next if $not_want{$wanted->[0]};
+
+ my %symbols = $class->_exporter_expand_sub(@$wanted, $global_opts, $permitted);
+ $class->_exporter_install_sub($_, $wanted->[1], $global_opts, $symbols{$_})
+ for keys %symbols;
+ }
+}
+
+sub unimport
+{
+ my $class = shift;
+ my $global_opts = +{ @_ && ref($_[0]) eq q(HASH) ? %{+shift} : () };
+ $global_opts->{into} = caller unless exists $global_opts->{into};
+ $global_opts->{is_unimport} = 1;
+
+ my @want;
+ my %not_want; $global_opts->{not} = \%not_want;
+ my @args = do { our %TRACKED; @_ ? @_ : keys(%{$TRACKED{$class}{$global_opts->{into}}}) };
+ my $opts = mkopt(\@args);
+ $class->$_process_optlist($global_opts, $opts, \@want, \%not_want);
+
+ my $permitted = $class->_exporter_permitted_regexp($global_opts);
+ $class->_exporter_validate_unimport_opts($global_opts);
+
+ my $expando = $class->can('_exporter_expand_sub');
+ $expando = undef if $expando == \&_exporter_expand_sub;
+
+ for my $wanted (@want)
+ {
+ next if $not_want{$wanted->[0]};
+
+ if ($wanted->[1])
+ {
+ _carp("Passing options to unimport '%s' makes no sense", $wanted->[0])
+ unless (ref($wanted->[1]) eq 'HASH' and not keys %{$wanted->[1]});
+ }
+
+ my %symbols = defined($expando)
+ ? $class->$expando(@$wanted, $global_opts, $permitted)
+ : ($wanted->[0] => sub { "dummy" });
+ $class->_exporter_uninstall_sub($_, $wanted->[1], $global_opts)
+ for keys %symbols;
+ }
+}
+
+# Called once per import/unimport, passed the "global" import options.
+# Expected to validate the options and carp or croak if there are problems.
+# Can also take the opportunity to do other stuff if needed.
+#
+sub _exporter_validate_opts { 1 }
+sub _exporter_validate_unimport_opts { 1 }
+
+# Called after expanding a tag or regexp to merge the tag's options with
+# any sub-specific options.
+#
+sub _exporter_merge_opts
+{
+ my $class = shift;
+ my ($tag_opts, $global_opts, @stuff) = @_;
+
+ $tag_opts = {} unless ref($tag_opts) eq q(HASH);
+ _croak('Cannot provide an -as option for tags')
+ if exists $tag_opts->{-as} && ref $tag_opts->{-as} ne 'CODE';
+
+ my $optlist = mkopt(\@stuff);
+ for my $export (@$optlist)
+ {
+ next if defined($export->[1]) && ref($export->[1]) ne q(HASH);
+
+ my %sub_opts = ( %{ $export->[1] or {} }, %$tag_opts );
+ $sub_opts{-prefix} = sprintf('%s%s', $tag_opts->{-prefix}, $export->[1]{-prefix})
+ if exists($export->[1]{-prefix}) && exists($tag_opts->{-prefix});
+ $sub_opts{-suffix} = sprintf('%s%s', $export->[1]{-suffix}, $tag_opts->{-suffix})
+ if exists($export->[1]{-suffix}) && exists($tag_opts->{-suffix});
+ $export->[1] = \%sub_opts;
+ }
+ return @$optlist;
+}
+
+# Given a tag name, looks it up in %EXPORT_TAGS and returns the list of
+# associated functions. The default implementation magically handles tags
+# "all" and "default". The default implementation interprets any undefined
+# tags as being global options.
+#
+sub _exporter_expand_tag
+{
+ no strict qw(refs);
+
+ my $class = shift;
+ my ($name, $value, $globals) = @_;
+ my $tags = \%{"$class\::EXPORT_TAGS"};
+
+ return $class->_exporter_merge_opts($value, $globals, $tags->{$name}->($class, @_))
+ if ref($tags->{$name}) eq q(CODE);
+
+ return $class->_exporter_merge_opts($value, $globals, @{$tags->{$name}})
+ if exists $tags->{$name};
+
+ return $class->_exporter_merge_opts($value, $globals, @{"$class\::EXPORT"}, @{"$class\::EXPORT_OK"})
+ if $name eq 'all';
+
+ return $class->_exporter_merge_opts($value, $globals, @{"$class\::EXPORT"})
+ if $name eq 'default';
+
+ $globals->{$name} = $value || 1;
+ return;
+}
+
+# Given a regexp-like string, looks it up in @EXPORT_OK and returns the
+# list of matching functions.
+#
+sub _exporter_expand_regexp
+{
+ no strict qw(refs);
+ our %TRACKED;
+
+ my $class = shift;
+ my ($name, $value, $globals) = @_;
+ my $compiled = eval("qr$name");
+
+ my @possible = $globals->{is_unimport}
+ ? keys( %{$TRACKED{$class}{$globals->{into}}} )
+ : @{"$class\::EXPORT_OK"};
+
+ $class->_exporter_merge_opts($value, $globals, grep /$compiled/, @possible);
+}
+
+# Helper for _exporter_expand_sub. Returns a regexp matching all subs in
+# the exporter package which are available for export.
+#
+sub _exporter_permitted_regexp
+{
+ no strict qw(refs);
+ my $class = shift;
+ my $re = join "|", map quotemeta, sort {
+ length($b) <=> length($a) or $a cmp $b
+ } @{"$class\::EXPORT"}, @{"$class\::EXPORT_OK"};
+ qr{^(?:$re)$}ms;
+}
+
+# Given a sub name, returns a hash of subs to install (usually just one sub).
+# Keys are sub names, values are coderefs.
+#
+sub _exporter_expand_sub
+{
+ my $class = shift;
+ my ($name, $value, $globals, $permitted) = @_;
+ $permitted ||= $class->_exporter_permitted_regexp($globals);
+
+ no strict qw(refs);
+
+ my $sigil = "&";
+ if ($name =~ /\A([&\$\%\@\*])(.+)\z/) {
+ $sigil = $1;
+ $name = $2;
+ if ($sigil eq '*') {
+ _croak("Cannot export symbols with a * sigil");
+ }
+ }
+ my $sigilname = $sigil eq '&' ? $name : "$sigil$name";
+
+ if ($sigilname =~ $permitted)
+ {
+ my $generatorprefix = {
+ '&' => "_generate_",
+ '$' => "_generateScalar_",
+ '@' => "_generateArray_",
+ '%' => "_generateHash_",
+ }->{$sigil};
+
+ my $generator = $class->can("$generatorprefix$name");
+ return $sigilname => $class->$generator($sigilname, $value, $globals) if $generator;
+
+ my $sub = $class->can($name);
+ return $sigilname => $sub if $sub;
+
+ # Could do this more cleverly, but this works.
+ if ($sigil ne '&') {
+ my $evalled = eval "\\${sigil}${class}::${name}";
+ return $sigilname => $evalled if $evalled;
+ }
+ }
+
+ $class->_exporter_fail(@_);
+}
+
+# Called by _exporter_expand_sub if it is unable to generate a key-value
+# pair for a sub.
+#
+sub _exporter_fail
+{
+ my $class = shift;
+ my ($name, $value, $globals) = @_;
+ return if $globals->{is_unimport};
+ _croak("Could not find sub '%s' exported by %s", $name, $class);
+}
+
+# Actually performs the installation of the sub into the target package. This
+# also handles renaming the sub.
+#
+sub _exporter_install_sub
+{
+ my $class = shift;
+ my ($name, $value, $globals, $sym) = @_;
+
+ my $into = $globals->{into};
+ my $installer = $globals->{installer} || $globals->{exporter};
+
+ $name =
+ ref $globals->{as} ? $globals->{as}->($name) :
+ ref $value->{-as} ? $value->{-as}->($name) :
+ exists $value->{-as} ? $value->{-as} :
+ $name;
+
+ return unless defined $name;
+
+ my $sigil = "&";
+ unless (ref($name)) {
+ if ($name =~ /\A([&\$\%\@\*])(.+)\z/) {
+ $sigil = $1;
+ $name = $2;
+ if ($sigil eq '*') {
+ _croak("Cannot export symbols with a * sigil");
+ }
+ }
+ my ($prefix) = grep defined, $value->{-prefix}, $globals->{prefix}, q();
+ my ($suffix) = grep defined, $value->{-suffix}, $globals->{suffix}, q();
+ $name = "$prefix$name$suffix";
+ }
+
+ my $sigilname = $sigil eq '&' ? $name : "$sigil$name";
+
+# if ({qw/$ SCALAR @ ARRAY % HASH & CODE/}->{$sigil} ne ref($sym)) {
+# warn $sym;
+# warn $sigilname;
+# _croak("Reference type %s does not match sigil %s", ref($sym), $sigil);
+# }
+
+ return ($$name = $sym) if ref($name) eq q(SCALAR);
+ return ($into->{$sigilname} = $sym) if ref($into) eq q(HASH);
+
+ no strict qw(refs);
+ our %TRACKED;
+
+ if (ref($sym) eq 'CODE' and exists &{"$into\::$name"} and \&{"$into\::$name"} != $sym)
+ {
+ my ($level) = grep defined, $value->{-replace}, $globals->{replace}, q(0);
+ my $action = {
+ carp => \&_carp,
+ 0 => \&_carp,
+ '' => \&_carp,
+ warn => \&_carp,
+ nonfatal => \&_carp,
+ croak => \&_croak,
+ fatal => \&_croak,
+ die => \&_croak,
+ }->{$level} || sub {};
+
+ # Don't complain about double-installing the same sub. This isn't ideal
+ # because the same named sub might be generated in two different ways.
+ $action = sub {} if $TRACKED{$class}{$into}{$sigilname};
+
+ $action->(
+ $action == \&_croak
+ ? "Refusing to overwrite existing sub '%s::%s' with sub '%s' exported by %s"
+ : "Overwriting existing sub '%s::%s' with sub '%s' exported by %s",
+ $into,
+ $name,
+ $_[0],
+ $class,
+ );
+ }
+
+ $TRACKED{$class}{$into}{$sigilname} = $sym;
+
+ no warnings qw(prototype);
+ $installer
+ ? $installer->($globals, [$sigilname, $sym])
+ : (*{"$into\::$name"} = $sym);
+}
+
+sub _exporter_uninstall_sub
+{
+ our %TRACKED;
+ my $class = shift;
+ my ($name, $value, $globals, $sym) = @_;
+ my $into = $globals->{into};
+ ref $into and return;
+
+ no strict qw(refs);
+
+ my $sigil = "&";
+ if ($name =~ /\A([&\$\%\@\*])(.+)\z/) {
+ $sigil = $1;
+ $name = $2;
+ if ($sigil eq '*') {
+ _croak("Cannot export symbols with a * sigil");
+ }
+ }
+ my $sigilname = $sigil eq '&' ? $name : "$sigil$name";
+
+ if ($sigil ne '&') {
+ _croak("Unimporting non-code symbols not supported yet");
+ }
+
+ # Cowardly refuse to uninstall a sub that differs from the one
+ # we installed!
+ my $our_coderef = $TRACKED{$class}{$into}{$name};
+ my $cur_coderef = exists(&{"$into\::$name"}) ? \&{"$into\::$name"} : -1;
+ return unless $our_coderef == $cur_coderef;
+
+ my $stash = \%{"$into\::"};
+ my $old = delete $stash->{$name};
+ my $full_name = join('::', $into, $name);
+ foreach my $type (qw(SCALAR HASH ARRAY IO)) # everything but the CODE
+ {
+ next unless defined(*{$old}{$type});
+ *$full_name = *{$old}{$type};
+ }
+
+ delete $TRACKED{$class}{$into}{$name};
+}
+
+sub mkopt
+{
+ my $in = shift or return [];
+ my @out;
+
+ $in = [map(($_ => ref($in->{$_}) ? $in->{$_} : ()), sort keys %$in)]
+ if ref($in) eq q(HASH);
+
+ for (my $i = 0; $i < @$in; $i++)
+ {
+ my $k = $in->[$i];
+ my $v;
+
+ ($i == $#$in) ? ($v = undef) :
+ !defined($in->[$i+1]) ? (++$i, ($v = undef)) :
+ !ref($in->[$i+1]) ? ($v = undef) :
+ ($v = $in->[++$i]);
+
+ push @out, [ $k => $v ];
+ }
+
+ \@out;
+}
+
+sub mkopt_hash
+{
+ my $in = shift or return;
+ my %out = map +($_->[0] => $_->[1]), @{ mkopt($in) };
+ \%out;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding utf-8
+
+=for stopwords frobnicate greps regexps
+
+=head1 NAME
+
+Exporter::Tiny - an exporter with the features of Sub::Exporter but only core dependencies
+
+=head1 SYNOPSIS
+
+ package MyUtils;
+ use base "Exporter::Tiny";
+ our @EXPORT = qw(frobnicate);
+ sub frobnicate { ... }
+ 1;
+
+ package MyScript;
+ use MyUtils "frobnicate" => { -as => "frob" };
+ print frob(42);
+ exit;
+
+=head1 DESCRIPTION
+
+Exporter::Tiny supports many of Sub::Exporter's external-facing features
+including renaming imported functions with the C<< -as >>, C<< -prefix >> and
+C<< -suffix >> options; explicit destinations with the C<< into >> option;
+and alternative installers with the C<< installer >> option. But it's written
+in only about 40% as many lines of code and with zero non-core dependencies.
+
+Its internal-facing interface is closer to Exporter.pm, with configuration
+done through the C<< @EXPORT >>, C<< @EXPORT_OK >> and C<< %EXPORT_TAGS >>
+package variables.
+
+If you are trying to B a module that inherits from Exporter::Tiny,
+then look at:
+
+=over
+
+=item *
+
+L
+
+=item *
+
+L
+
+=back
+
+If you are trying to B