From 3444364ae5668eaecec6fff1d3fcd81838752633 Mon Sep 17 00:00:00 2001
From: ian <ian>
Date: Sat, 2 Mar 2002 17:42:40 +0000
Subject: [PATCH] Cache datagram format parsing; profiled.

---
 make-probes.tcl | 299 +++++++++++++++++++++++++++---------------------
 1 file changed, 170 insertions(+), 129 deletions(-)

diff --git a/make-probes.tcl b/make-probes.tcl
index 6a033ff..52a580e 100755
--- a/make-probes.tcl
+++ b/make-probes.tcl
@@ -1,6 +1,10 @@
 #!/usr/bin/tclsh8.2
 
 
+       package require profiler
+       ::profiler::init
+
+
 set debug_level 1
 
 proc debug {level str} {
@@ -57,7 +61,6 @@ namespace eval Random-Bytes {
 	    error "openssl bf-ofb exited unexpectedly"
 	}
 	set y [packet-fromstring $x]
-	if {[string length $y] != $n*2} { error "binary format failed $n $y" }
 	return $y
     }
 }
@@ -258,151 +261,175 @@ proc get/string {s v minlen maxlen first rest} {
 }
 
 
-proc assemble {outvarname format} {
-    # format should look like those RFC diagrams.
-    # +-+-+ stuff and good formatting is mandatory.
-    # Tabs are forbidden.
-    #
-    # Field names are converted to lowercase; internal spaces
-    # are replaced with _.  They are then assumed to be
-    # variable names in the caller's scope.  The packet is
-    # assembled from those values (which must all be set)
-    # and stored in $varname in the caller's scope.
-    #
-    # Variables ?_whatever will be *set* with the location of the
-    # field in the string (in internal format); the corresponding
-    # `whatever' (with the ?_ stripped) will be read when assembling.
-    #
-    # Field name `0' means set the field to zero.
-
-    upvar 1 $outvarname out
-    set out {}
-    set lno 0
-    debug 7 "ASSEMBLY $outvarname\n$format"
-    foreach l [split $format "\n"] {
-	incr lno
-	if {[regexp -nocase {^ *\| +\| *$} $l]} {
-	    if {![info exists wordbits]} {
-		error "vspace not in data @$lno\n?$l?"
-	    }
-	    incr words
-	} elseif {[regexp -nocase {^ *[|? a-z0-9]+$} $l]} {
-	    if {[info exists words]} {
-		error "data without delimline @$lno\n?$l?"
+namespace eval Assembler {
+    namespace export assemble assembly-overwrite
+
+    proc assemble {outvarname format} {
+	# format should look like those RFC diagrams.
+	# +-+-+ stuff and good formatting is mandatory.
+	# Tabs are forbidden.
+	#
+	# Field names are converted to lowercase; internal spaces
+	# are replaced with _.  They are then assumed to be
+	# variable names in the caller's scope.  The packet is
+	# assembled from those values (which must all be set)
+	# and stored in $varname in the caller's scope.
+	#
+	# Variables ?_whatever will be *set* with the location of the
+	# field in the string (in internal format); the corresponding
+	# `whatever' (with the ?_ stripped) will be read when assembling.
+	#
+	# Field name `0' means set the field to zero.
+
+	variable cache
+	upvar 1 $outvarname out
+	if {[catch { set parsed $cache($format) }]} {
+	    set parsed [parse $format]
+	    set cache($format) $parsed
+	}
+
+	manyset $parsed outbytes lout
+	set out [string repeat 00 $outbytes]
+	foreach {location varname locvarname} $lout {
+	    if {"$varname" == "0"} {
+		set value 0
+	    } else {
+		set value [uplevel 1 [list set $varname]]
 	    }
-	    set words 1
-	    set cue $l
-	} elseif {[regexp {^ *[-+]+ *$} $l]} {
-	    set wordbits 0
-	    set newlineform {}
-	    while {[regexp {^([-= ]+)\+(.*)$} $l dummy before after]} {
-		set atpos([string length $before]) $wordbits
-		incr wordbits
-		set l "$before=$after"
-		append newlineform "@[string length $before]:$wordbits "
+	    if {[string length $locvarname]} {
+		upvar 1 $locvarname lv
+		set lv $location
 	    }
-	    incr wordbits -1
-	    append newlineform $wordbits
-	    if {[info exists lineform]} {
-		if {"$newlineform" != "$lineform"} {
- error "format change @$lno\n?$l?\n$wordformat != $oldwordformat"
+	    assembly-overwrite out $location $value
+	}
+    }
+
+    proc parse {format} {
+	set lno 0
+	set outbytes 0
+	debug 7 "ASSEMBLY $format"
+	foreach l [split $format "\n"] {
+	    incr lno
+	    if {[regexp -nocase {^ *\| +\| *$} $l]} {
+		if {![info exists wordbits]} {
+		    error "vspace not in data @$lno\n?$l?"
 		}
-		if {![info exists words] || $words<0} {
-		    error "consecutive delimlines @$lno\n?$l?"
+		incr words
+	    } elseif {[regexp -nocase {^ *[|? a-z0-9]+$} $l]} {
+		if {[info exists words]} {
+		    error "data without delimline @$lno\n?$l?"
 		}
-		append out [string repeat 00 [expr {$words*$wordbits/8}]]
-		set l $cue
-		while {[regexp -nocase \
-			{^([ =]*)\|( *[? a-z0-9]*[a-z0-9] *)\|(.*)$} \
-			$l dummy before midpart after]} {
-		    debug 7 "RWORKG ?$l?"
-		    set varname [string tolower [string trim $midpart]]
-		    set varname [string map {{ } _} $varname]
-		    set p1 [string length $before]
-		    set p2 [expr {
-			[string length $before] +
-			[string length $midpart] + 1
-		    }]
-		    if {![info exists atpos($p1)] ||
-			![info exists atpos($p2)]} {
- error "vdelims not found @$lno $varname $p1 $p2 -- $lineform ?$cue?"
+		set words 1
+		set cue $l
+	    } elseif {[regexp {^ *[-+]+ *$} $l]} {
+		set wordbits 0
+		set newlineform {}
+		while {[regexp {^([-= ]+)\+(.*)$} $l dummy before after]} {
+		    set atpos([string length $before]) $wordbits
+		    incr wordbits
+		    set l "$before=$after"
+		    append newlineform "@[string length $before]:$wordbits "
+		}
+		incr wordbits -1
+		append newlineform $wordbits
+		if {[info exists lineform]} {
+		    if {"$newlineform" != "$lineform"} {
+ error "format change @$lno\n?$l?\n$wordformat != $oldwordformat"
+		    }
+		    if {![info exists words] || $words<0} {
+			error "consecutive delimlines @$lno\n?$l?"
 		    }
-		    set bit1 [expr {
-			[string length $out]*4
-			- $words*$wordbits
-			+ $atpos($p1)
-		    }]
-		    set bitlen [expr {
-			$atpos($p2) - $atpos($p1) + ($words-1)*$wordbits
-		    }]
-		    set location [list $bit1 $bitlen $outvarname-$varname]
-		    if {[regexp {^\?_(.*)} $varname dummy realvarname]} {
-			debug 7 "LOCATING $varname $location"
-			upvar 1 $varname locvarname
-			set locvarname $location
-                        set varname $realvarname
+		    incr outbytes [expr {$words*$wordbits/8}]
+		    set l $cue
+		    while {[regexp -nocase \
+			    {^([ =]*)\|( *[? a-z0-9]*[a-z0-9] *)\|(.*)$} \
+			    $l dummy before midpart after]} {
+			debug 7 "RWORKG ?$l?"
+			set varname [string tolower [string trim $midpart]]
+			set varname [string map {{ } _} $varname]
+			set p1 [string length $before]
+			set p2 [expr {
+			    [string length $before] +
+			    [string length $midpart] + 1
+			}]
+			if {![info exists atpos($p1)] ||
+			    ![info exists atpos($p2)]} {
+ error "vdelims not found @$lno $varname $p1 $p2 -- $lineform ?$cue?"
+			}
+			set bit1 [expr {
+			    $outbytes*8
+			    - $words*$wordbits
+			    + $atpos($p1)
+			}]
+			set bitlen [expr {
+			    $atpos($p2) - $atpos($p1) + ($words-1)*$wordbits
+			}]
+			set location [list $bit1 $bitlen $varname]
+			if {[regexp {^\?_(.*)} $varname dummy realvarname]} {
+			    debug 7 "LOCATING $varname $location"
+			    set locvarname $varname
+			    set varname $realvarname
+			} else {
+			    set locvarname {}
+			}
+			lappend lout $location $varname $locvarname
+			set l "$before="
+			append l [string repeat = [string length $midpart]]
+			append l |$after
 		    }
-		    if {"$varname" == "0"} {
-			set value 0
-		    } else {
-			set value [uplevel 1 [list set $varname]]
+		    debug 7 "REMAIN ?$l?"
+		} else {
+		    if {$wordbits % 8 || $wordbits >32} {
+			error "bad wordbits $wordbits @$lno ?$l? $newlineform"
 		    }
-		    assembly-overwrite out $location $value
-		    set l "$before="
-		    append l [string repeat = [string length $midpart]]
-		    append l |$after
+		    set lineform $newlineform
 		}
-		debug 7 "REMAIN ?$l?"
+		catch { unset words }
+	    } elseif {[regexp {^ *$} $l]} {
 	    } else {
-		if {$wordbits % 8 || $wordbits >32} {
-		    error "bad wordbits $wordbits @$lno ?$l? $newlineform"
-		}
-		set lineform $newlineform
+		error "huh? @$lno ?$l?"
 	    }
-	    catch { unset words }
-	} elseif {[regexp {^ *$} $l]} {
-	} else {
-	    error "huh? @$lno ?$l?"
 	}
+	debug 7 "ASSEMBLY\n$outbytes\n$lout\n"
+	return [list $outbytes $lout]
     }
-    debug 7 "ASSEMBLY\n$out\n"
-    return $out
-}
 
-proc assembly-overwrite {outvarname location value} {
-    upvar 1 $outvarname out
-    manyset $location bit1 bitlen diag
-    debug 8 "ASSEMBLY $diag == $value == 0x[format %x $value] (@$bit1+$bitlen)"
-    if {$bitlen < 32 && $value >= (1<<$bitlen)} {
-	error "$diag $value >= 2**$bitlen"
-    }
-    if {!($bit1 % 8) && !($bitlen % 8)} {
-	set char0no [expr {$bit1/4}]
-	set charlen [expr {$bitlen/4}]
-	set chareno [expr {$char0no + $charlen -1}]
-	set repl [format %0${charlen}x $value]
-	set out [string replace $out $char0no $chareno $repl]
-    } else {
-	while {$bitlen > 0} {
-	    set byteno [expr {$bit1 / 8}]
-	    set char0no [expr {$byteno*2}]
-	    set char1no [expr {$char0no+1}]
-	    set bytebit [expr {128>>($bit1 % 8)}]
-	    set byte 0x[string range $out $char0no $char1no]
-	    debug 7 "< $bit1+$bitlen $byteno $char0no $bytebit $byte $out"
-	    set byte [expr {
-		($value & (1<<($bitlen-1)))
-		? ($byte | $bytebit)
-		: ($byte & ~$bytebit)
-	    }]
-	    set out [string replace $out $char0no $char1no [format %02x $byte]]
+    proc assembly-overwrite {outvarname location value} {
+	upvar 1 $outvarname out
+	manyset $location bit1 bitlen diag
+ debug 8 "ASSEMBLY $diag == $value == 0x[format %x $value] (@$bit1+$bitlen)"
+	if {$bitlen < 32 && $value >= (1<<$bitlen)} {
+	    error "$diag $value >= 2**$bitlen"
+	}
+	if {!($bit1 % 8) && !($bitlen % 8)} {
+	    set char0no [expr {$bit1/4}]
+	    set charlen [expr {$bitlen/4}]
+	    set chareno [expr {$char0no + $charlen -1}]
+	    set repl [format %0${charlen}x $value]
+	    set out [string replace $out $char0no $chareno $repl]
+	} else {
+	    while {$bitlen > 0} {
+		set byteno [expr {$bit1 / 8}]
+		set char0no [expr {$byteno*2}]
+		set char1no [expr {$char0no+1}]
+		set bytebit [expr {128>>($bit1 % 8)}]
+		set byte 0x[string range $out $char0no $char1no]
+		debug 7 "< $bit1+$bitlen $byteno $char0no $bytebit $byte $out"
+		set byte [expr {
+		    ($value & (1<<($bitlen-1)))
+		    ? ($byte | $bytebit)
+		    : ($byte & ~$bytebit)
+		}]
+		set out [string replace $out $char0no $char1no \
+			[format %02x $byte]]
  debug 8 "> $bit1+$bitlen $byteno $char0no $bytebit 0x[format %02x $byte] $out"
-	    incr bitlen -1
-	    incr bit1
+		incr bitlen -1
+		incr bit1
+	    }
 	}
     }
 }
-
+namespace import Assembler::*
 
 proc gen_1_ip {mtu} {
     # RFC791
@@ -757,3 +784,17 @@ if {![llength $argv]} {
 } else {
     foreach count $argv { emit $count }
 }
+
+
+puts [::profiler::dump]
+
+puts ---------------------IWJ
+
+puts [::profiler::print]
+
+puts ---------------------IWJ
+
+foreach i [::profiler::sortFunctions totalRuntime] {
+    manyset $i f v
+    puts [::profiler::print $f]
+}
-- 
2.30.2