Check-in [e06c6257c1]
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:directUnset interacts with the callframe and retuns CALLFRAME FAIL
Timelines: family | ancestors | descendants | both | kbk-refactor-directops
Files: files | file ages | folders
SHA3-256: e06c6257c12dc8a337819b02515714ab0841d4b3a580fc723b5968595ce510df
User & Date: kbk 2019-11-13 03:55:40
Context
2019-11-15
23:09
Change return type of directUnset and directUnsetArray from CALLFRAME FAIL to CALLFRAME FAIL BOOLEAN, because void values aren't handled well in the code issuer. Simply discard the unused result. check-in: 731e9cafc6 user: kbk tags: kbk-refactor-directops
2019-11-13
03:55
directUnset interacts with the callframe and retuns CALLFRAME FAIL check-in: e06c6257c1 user: kbk tags: kbk-refactor-directops
2019-11-12
03:13
direct append operations interact with the callframe check-in: 9837744239 user: kbk tags: kbk-refactor-directops
Changes

Changes to codegen/build.tcl.

2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870

2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881

2882

2883
2884
2885
2886
2887
2888
2889
2890
2891
2892

2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903

2904

2905

2906
2907
2908
2909
2910
2911
2912
2913
	{cf varname elem value ec {name ""}} \
	{
	    set result [my call ${tcl.direct.set} \
			    [list $varname $elem $value $ec] $name]
	    return [my frame.pack $cf $result]
	}

    # Builder:directUnset(STRING,INT) --
    #
    #	Unset a variable, which should be referred to by a fully-qualified
    #	name. NOTE: this operation can fail because of traces so it produces a
    #	ZEROONE FAIL (with meaningless value when not failing). Quadcode
    #	implementation ('directUnset').
    #
    # Parameters:

    #	varname -
    #		The variable name as an LLVM value reference.
    #	flag -	Whether failures are allowed, as an LLVM value reference.
    #	ec -	Where to write the error code if an error happens.
    #	name (optional) -
    #		A name to give to the result value.
    #
    # Results:
    #	Whether the unset was successful.

    method directUnset(STRING,INT) {varname flag ec {name ""}} {

	my call ${tcl.direct.unset} [list $varname {} $flag $ec] $name

    }

    # Builder:directArrayUnset(STRING,STRING,INT) --
    #
    #	Unset an array variable, which should be referred to by a
    #	fully-qualified name. NOTE: this operation can fail because of traces
    #	so it produces a ZEROONE FAIL (with meaningless value when not
    #	failing). Quadcode implementation ('directArrayUnset').
    #
    # Parameters:

    #	varname -
    #		The variable name as an LLVM value reference.
    #	elem -	The element name as an LLVM value reference.
    #	flag -	Whether failures are allowed, as an LLVM value reference.
    #	ec -	Where to write the error code if an error happens.
    #	name (optional) -
    #		A name to give to the result value.
    #
    # Results:
    #	Whether the unset was successful.


    method directArrayUnset(STRING,STRING,INT) {varname elem flag ec {name ""}} {

	my call ${tcl.direct.unset} [list $varname $elem $flag $ec] $name

    }

    # Builder:directIsArray(STRING) --
    #
    #	Tests if the variable whose name we are given is an array. NOTE: this
    #	operation can fail because of traces so it produces a BOOL FAIL.
    #	Quadcode implementation ('directIsArray').
    #






|







>










|
>
|
>


|







>











>
|
>
|
>
|







2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
	{cf varname elem value ec {name ""}} \
	{
	    set result [my call ${tcl.direct.set} \
			    [list $varname $elem $value $ec] $name]
	    return [my frame.pack $cf $result]
	}

    # Builder:directUnset(CALLFRAME,STRING,INT) --
    #
    #	Unset a variable, which should be referred to by a fully-qualified
    #	name. NOTE: this operation can fail because of traces so it produces a
    #	ZEROONE FAIL (with meaningless value when not failing). Quadcode
    #	implementation ('directUnset').
    #
    # Parameters:
    #	cf -	Callframe in which non-fully-qualified names should resolve
    #	varname -
    #		The variable name as an LLVM value reference.
    #	flag -	Whether failures are allowed, as an LLVM value reference.
    #	ec -	Where to write the error code if an error happens.
    #	name (optional) -
    #		A name to give to the result value.
    #
    # Results:
    #	Whether the unset was successful.

    method directUnset(CALLFRAME,STRING,INT) {cf varname flag ec {name ""}} {
	set result [my call ${tcl.direct.unset} \
			[list $varname {} $flag $ec] $name]
	return [my frame.pack $cf $result]
    }

    # Builder:directArrayUnset(CALLFRAME,STRING,STRING,INT) --
    #
    #	Unset an array variable, which should be referred to by a
    #	fully-qualified name. NOTE: this operation can fail because of traces
    #	so it produces a ZEROONE FAIL (with meaningless value when not
    #	failing). Quadcode implementation ('directArrayUnset').
    #
    # Parameters:
    #	cf -	Callframe in which non-fully-qualified names should resolve
    #	varname -
    #		The variable name as an LLVM value reference.
    #	elem -	The element name as an LLVM value reference.
    #	flag -	Whether failures are allowed, as an LLVM value reference.
    #	ec -	Where to write the error code if an error happens.
    #	name (optional) -
    #		A name to give to the result value.
    #
    # Results:
    #	Whether the unset was successful.

    method directArrayUnset(CALLFRAME,STRING,STRING,INT) \
	{cf varname elem flag ec {name ""}} {
	    set result [my call ${tcl.direct.unset} \
			    [list $varname $elem $flag $ec] $name]
	    return [my frame.pack $cf $result]
	}

    # Builder:directIsArray(STRING) --
    #
    #	Tests if the variable whose name we are given is an array. NOTE: this
    #	operation can fail because of traces so it produces a BOOL FAIL.
    #	Quadcode implementation ('directIsArray').
    #

Changes to codegen/compile.tcl.

517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
...
539
540
541
542
543
544
545
546

547
548
549
550
551
552
553
		    set srcs [my ConvertIndices 0 strlen 1 2]
		    set res [$b $opcode {*}$srcs $errorCode $name]
		    if {"FAIL" in [my ValueTypes $tgt]} {
			my SetErrorLine $errorCode [$b maybe $res]
		    }
		    my StoreResult $tgt $res
		}
		"directUnset" -
		"directArrayUnset" - "directIsArray" - "directMakeArray" -
		"regexp" - "listLength" -
		"listIn" - "listNotIn" - "dictIterStart" -
		"dictAppend" - "dictIncr" - "dictLappend" - "dictSize" -
		"div" - "expon" - "mod" - "verifyList" -
		"dictGetOrNexist" - "dictSetOrUnset" {
		    set srcs [lassign $l opcode tgt]
		    set name [my LocalVarName $tgt]
................................................................................
		    my StoreResult $tgt $res
		}
		"directGet" - "directSet" -
		"directArrayGet" - "directArraySet" -
		"directAppend" - "directLappend" -
		"directLappendList" -
		"directArrayAppend" - "directArrayLappend" -
		"directArrayLappendList" 

		{
		    set srcs [lassign $l opcode tgt]
		    set name [my LocalVarName $tgt]
		    append opcode ( [my ValueTypes {*}$srcs] )
		    set srcs [lmap s $srcs {my LoadOrLiteral $s}]
		    set res [$b $opcode {*}$srcs $errorCode $name]
		    set resNoCF [$b frame.value $res]






<
|







 







|
>







517
518
519
520
521
522
523

524
525
526
527
528
529
530
531
...
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
		    set srcs [my ConvertIndices 0 strlen 1 2]
		    set res [$b $opcode {*}$srcs $errorCode $name]
		    if {"FAIL" in [my ValueTypes $tgt]} {
			my SetErrorLine $errorCode [$b maybe $res]
		    }
		    my StoreResult $tgt $res
		}

		"directIsArray" - "directMakeArray" -
		"regexp" - "listLength" -
		"listIn" - "listNotIn" - "dictIterStart" -
		"dictAppend" - "dictIncr" - "dictLappend" - "dictSize" -
		"div" - "expon" - "mod" - "verifyList" -
		"dictGetOrNexist" - "dictSetOrUnset" {
		    set srcs [lassign $l opcode tgt]
		    set name [my LocalVarName $tgt]
................................................................................
		    my StoreResult $tgt $res
		}
		"directGet" - "directSet" -
		"directArrayGet" - "directArraySet" -
		"directAppend" - "directLappend" -
		"directLappendList" -
		"directArrayAppend" - "directArrayLappend" -
		"directArrayLappendList" -
		"directUnset" -	"directArrayUnset"
		{
		    set srcs [lassign $l opcode tgt]
		    set name [my LocalVarName $tgt]
		    append opcode ( [my ValueTypes {*}$srcs] )
		    set srcs [lmap s $srcs {my LoadOrLiteral $s}]
		    set res [$b $opcode {*}$srcs $errorCode $name]
		    set resNoCF [$b frame.value $res]

Changes to codegen/struct.tcl.

2957
2958
2959
2960
2961
2962
2963



2964
2965
2966
2967
2968
2969
2970
....
3001
3002
3003
3004
3005
3006
3007





3008
3009
3010
3011
3012
3013
3014
    #	Boolean that indicates whether we created the method with the
    #	requested signature.
    #
    # Side effects:
    # 	May create a method on the current object.

    method MakeTypecastWrapper {signature} {




	# This method inserts conversions to lift, e.g., INT to DOUBLE as
	# necessary, provided there is a way of generating the instruction
	# with DOUBLE in the first place.

	# First, extract the type signature that we're trying to generate.
	if {![regexp {^([^()]+)\(([\w, ]+)\)$} $signature -> name types]} {
................................................................................
	    }
	    set n ${name}([join $types2 ,])
	    if {$n eq $signature} continue
	    if {$n in [info class methods [self class]]} {
		lappend mapped $thiscost $n $cvts
	    }
	}






	# Select the cheapest conversion and generate the method that uses it.
	set num [llength $types]
	foreach {- n cvts} [lsort -stride 3 -integer -index 0 $mapped] {
	    set formals [lindex [info class definition [self class] $n] 0]
	    set body1 "set {string casts} {}"
	    set body2 ""






>
>
>







 







>
>
>
>
>







2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
....
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
    #	Boolean that indicates whether we created the method with the
    #	requested signature.
    #
    # Side effects:
    # 	May create a method on the current object.

    method MakeTypecastWrapper {signature} {

	::puts "Make typecast wrapper for $signature"; ::flush stdout
	set tick [clock microseconds]

	# This method inserts conversions to lift, e.g., INT to DOUBLE as
	# necessary, provided there is a way of generating the instruction
	# with DOUBLE in the first place.

	# First, extract the type signature that we're trying to generate.
	if {![regexp {^([^()]+)\(([\w, ]+)\)$} $signature -> name types]} {
................................................................................
	    }
	    set n ${name}([join $types2 ,])
	    if {$n eq $signature} continue
	    if {$n in [info class methods [self class]]} {
		lappend mapped $thiscost $n $cvts
	    }
	}

	set tock [clock microseconds]
	set dur [format "%.6f" [expr {1.0e-6 * ($tock - $tick)}]]
	::puts "Identified [expr {[llength $mapped]/3}] typecast candidates in $dur s"
	::flush stdout

	# Select the cheapest conversion and generate the method that uses it.
	set num [llength $types]
	foreach {- n cvts} [lsort -stride 3 -integer -index 0 $mapped] {
	    set formals [lindex [info class definition [self class] $n] 0]
	    set body1 "set {string casts} {}"
	    set body2 ""

Changes to quadcode/translate.tcl.

767
768
769
770
771
772
773

774
775
776
777
778
779
780

781
782
783
784
785
786
787
788
		my generate-callframe-op \
		    $pc directArraySet $var $var $elem $value
	    }
	    unsetStk {
		set flags [list literal [lindex $insn 1]]
		set var [list temp [incr depth -1]]
		# TODO: This assumes we're dealing with qualified names!

		my error-quads $pc directUnset {temp opd0} $var $flags
	    }
	    unsetArrayStk {
		set flags [list literal [lindex $insn 1]]
		set elem [list temp [incr depth -1]]
		set var [list temp [incr depth -1]]
		# TODO: This assumes we're dealing with qualified names!

		my error-quads $pc directArrayUnset {temp opd0} $var $elem $flags
	    }
	    dictGet {
		set idxNum [lindex $insn 1]
		set q {}
		for {set i 0} {$i < $idxNum} {incr i} {
		    # NOTE: Reversed
		    lappend q [list temp [incr depth -1]]






>
|






>
|







767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
		my generate-callframe-op \
		    $pc directArraySet $var $var $elem $value
	    }
	    unsetStk {
		set flags [list literal [lindex $insn 1]]
		set var [list temp [incr depth -1]]
		# TODO: This assumes we're dealing with qualified names!
		my generate-callframe-op $pc \
		    directUnset {temp opd0} $var $flags
	    }
	    unsetArrayStk {
		set flags [list literal [lindex $insn 1]]
		set elem [list temp [incr depth -1]]
		set var [list temp [incr depth -1]]
		# TODO: This assumes we're dealing with qualified names!
		my generate-callframe-op $pc directArrayUnset \
		    {temp opd0} $var $elem $flags
	    }
	    dictGet {
		set idxNum [lindex $insn 1]
		set q {}
		for {set i 0} {$i < $idxNum} {incr i} {
		    # NOTE: Reversed
		    lappend q [list temp [incr depth -1]]

Changes to quadcode/types.tcl.

764
765
766
767
768
769
770





771
772
773
774
775
776
777
778
779
780
781
	}
	directGet - directSet - directArrayGet - directArraySet -
	directAppend - directLappend - directLappendList -
	directArrayAppend - directArrayLappend - directArrayLappendList {
	    # Can't assume more; these may be touching traced variables
	    return [expr {$CALLFRAME | $STRING | $FAIL}]
	}





	directExists - directArrayExists {
	    return $BOOL
	}
	directUnset - directArrayUnset - directIsArray - directMakeArray {
	    return [expr {$BOOL | $FAIL}]
	}
	procLeave {
	    # Produces a pure FAIL
	    return $FAIL
	}
	default {






>
>
>
>
>



|







764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
	}
	directGet - directSet - directArrayGet - directArraySet -
	directAppend - directLappend - directLappendList -
	directArrayAppend - directArrayLappend - directArrayLappendList {
	    # Can't assume more; these may be touching traced variables
	    return [expr {$CALLFRAME | $STRING | $FAIL}]
	}
	directUnset - directArrayUnset {
	    # may be touching traced variables, and may fail but does not
	    # return a direct result
	    return [expr {$CALLFRAME | $FAIL}]
	}
	directExists - directArrayExists {
	    return $BOOL
	}
	directIsArray - directMakeArray {
	    return [expr {$BOOL | $FAIL}]
	}
	procLeave {
	    # Produces a pure FAIL
	    return $FAIL
	}
	default {