Tcl Source Code

Artifact b94b593ea383100503850e88ac2f4f51042076c2:

Attachment "memleak.tcl" to ticket [1913398fff] added by ctasada 2008-03-26 21:42:40.

---

package require platform

puts [info patchlevel]/[platform::identify]

proc get_used_memory {{getdiff 0}} {
	set pmemory -1
	set vmemory -1
	
	if {![info exists ::DBG_PHYSICAL_MEMORY]} {
		set ::DBG_PHYSICAL_MEMORY 0
		set ::DBG_VIRTUAL_MEMORY 0
	}
	
	if {$::tcl_platform(platform) == "windows"} {
		# A bit more complex than in Linux, and we need an external command, but also works ;)
		catch {exec pslist.exe -m [pid] /accepteula} result
		set lines [split $result "\n"]
		set result [split [join [lindex $lines 3]]]
		
		set pmemory [lindex $result 3]
		set vmemory [lindex $result 4]
	} else {
		set pmemory [exec ps --pid [pid] --format sz --no-header]
		set vmemory [exec ps --pid [pid] --format vsz --no-header]
	}
	
	if {$getdiff} {
		set diff_pmemory [expr {$pmemory - $::DBG_PHYSICAL_MEMORY}]
		set diff_vmemory [expr {$vmemory - $::DBG_VIRTUAL_MEMORY}]
	}
	
	set ::DBG_PHYSICAL_MEMORY $pmemory
	set ::DBG_VIRTUAL_MEMORY $vmemory
	
	if {$getdiff} {
		return [list $pmemory $vmemory [list $diff_pmemory $diff_vmemory]]
	}
	return [list $pmemory $vmemory]
}

proc get_nice_memory {{getdiff 0}} {
	set sep ","
		
	set mem [get_used_memory $getdiff]
	
	set pmemory [lindex $mem 0]
	set vmemory [lindex $mem 1]
	
	# Formats the number for nicer reading
	#regsub {^([-+]?\d+)(\d\d\d)} $pmemory "\\1$sep\\2" pmemory
	#regsub {^([-+]?\d+)(\d\d\d)} $vmemory "\\1$sep\\2" vmemory
	
    set result "Physical: [format %6d $pmemory] / Virtual: [format %6d $vmemory]"

	if {$getdiff} {
		set diff_pmemory [lindex $mem 2 0]
		set diff_vmemory [lindex $mem 2 1]

		#regsub {^([-+]?\d+)(\d\d\d)} $diff_pmemory "\\1$sep\\2" diff_pmemory
		#regsub {^([-+]?\d+)(\d\d\d)} $diff_vmemory "\\1$sep\\2" diff_vmemory
		
	    set result "$result > Difference (Physical: [format %6d $diff_pmemory] / Virtual: [format %6d $diff_vmemory])"
	}	
	
	return $result
}

proc create_globals {} {
	set ::DB_VARS ""
	set total 500
	for {set var 0} {$var < $total} {incr var} {
		lappend ::DB_VARS "GLOBAL_$var"
		set ::GLOBAL_$var ""
		
		set var_total 1000
		for {set elem 0} {$elem < $var_total} {incr elem} {
			set value [string repeat a [expr { int(15 * rand()) }]]
			lappend ::GLOBAL_$var $value
		}
		
		thread::send $::t1 [list lappend ::DB_VARS "GLOBAL_$var"]
		#thread::send $::t1 [list set "GLOBAL_$var" [set ::GLOBAL_$var]]
		thread::send $::t1 [list setvar "GLOBAL_$var" [set ::GLOBAL_$var]]
		
	}
}

proc modify_globals {} {
	foreach var $::DB_VARS {
		set tmp ""
		foreach value [set ::$var] {
			lappend tmp $value
		}
		set ::$var $tmp
		unset tmp
		
		#thread::send $::t1 [list set "$var" [set ::$var]]
		thread::send $::t1 [list setvar "$var" [set ::$var]]
	}
}

proc dbsave {} {
	set fd [open "mydb.dat" w]
	fconfigure $fd -encoding utf-8
	
	foreach var $::DB_VARS {
		puts $fd \{[list $var [set ::$var]]\}
	}
	
	close $fd
}

puts "Start           - [get_nice_memory]"

if {[catch {package require Thread}]} {
	load thread.dll
	package require Thread
}
set ::t1 [thread::create -preserved {
	proc setvar {v value} {
		set ::$v $value
		
		return
	}
	
	thread::wait
}]
puts "Create Threads  - [get_nice_memory 1]"

# Creates the global variables
create_globals
puts "Globals Created - [get_nice_memory 1]"

# Saves to a file
dbsave

puts "DB Saved        - [get_nice_memory 1]"

while {1} {
    # Modify some variables
    modify_globals
    puts "Modify          - [get_nice_memory 1]"

    # Save again
    dbsave
    puts "DB Saved        - [get_nice_memory 1]"
    
    update
}