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

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

Overview
Comment:This is getting somewhere; next up, using actual types we can now assume in code issue
Timelines: family | ancestors | descendants | both | list-and-dict-types
Files: files | file ages | folders
SHA3-256: 0ec315adace678fd9af1a9db3ad71baa3b4ed5a2323bd90c7874441d2f572e75
User & Date: dkf 2018-11-29 11:34:42
Context
2018-11-29
13:57
merge trunk check-in: b0b8f8280b user: dkf tags: list-and-dict-types
11:34
This is getting somewhere; next up, using actual types we can now assume in code issue check-in: 0ec315adac user: dkf tags: list-and-dict-types
2018-11-28
08:52
Default type conversions. check-in: 7a7e53d026 user: dkf tags: list-and-dict-types
Changes

Changes to codegen/build.tcl.

3043
3044
3045
3046
3047
3048
3049
































3050
3051
3052
3053
3054
3055
3056
....
4411
4412
4413
4414
4415
4416
4417
























4418
4419
4420
4421
4422
4423
4424
....
5545
5546
5547
5548
5549
5550
5551




























5552
5553
5554
5555
5556
5557
5558
....
6097
6098
6099
6100
6101
6102
6103
































































6104
6105
6106
6107
6108
6109
6110
    # Results:
    #	None.

    method dropReference {value} {
	my Call tcl.dropReference $value
	return
    }

































    # Builder:dropReference(STRING) --
    #
    #	Generate code to decrement the reference count of a value and delete
    #	the value if it has ceased to be used.
    #
    # Parameters:
................................................................................

    method instanceOf.ZEROONE_BOOLEAN(STRING) {value {name ""}} {
	my call ${tcl.isZeroOneBoolean} [list $value [Const false bool]] $name
    }
    method instanceOf.IMPURE_ZEROONE_BOOLEAN(STRING) {value {name ""}} {
	my call ${tcl.isZeroOneBoolean} [list $value [Const false bool]] $name
    }

























    # Builder:int --
    #
    #	Generate code to create an integer "literal".
    #
    # Parameters:
    #	value -	The Tcl integer that we are converting to an LLVM INT.
................................................................................
	if {[string match "* NEXIST" $type]} {
	    set type [string range $type 0 end-7]
	} elseif {[string match "NEXIST *" $type]} {
	    set type [string range $type 7 end]
	}
	my insert [my undef $type!] [Const true bool] 0 $name
    }





























    # Builder:unmaybe --
    #
    #	Get the value out of a FAIL or NEXIST. NOTE: The FAIL/NEXIST must be a
    #	Just or the result will be an 'undef'; test with the 'maybe' method
    #	first!
    #
................................................................................
    #	Returns an LLVM IMPURE NUMERIC value

    method packImpure(NUMERIC) {value {name ""}} {
	set sval [my stringify(NUMERIC) $value]
	my addReference(STRING) $sval
	return [my impure NUMERIC $sval $value $name]
    }

































































    # Builder:packImpure(ZEROONE BOOLEAN) --
    #
    #	Convert a ZEROONE BOOLEAN to an IMPURE ZEROONE BOOLEAN
    #
    # Parameters:
    #	value -	LLVM Value to pack into the 'impure' structure






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
....
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
....
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
....
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192
6193
6194
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
6249
6250
6251
6252
6253
6254
6255
6256
6257
6258
    # Results:
    #	None.

    method dropReference {value} {
	my Call tcl.dropReference $value
	return
    }

    # Builder:dropReference(IMPURE EMPTY DICT) --
    #
    #	Generate code to decrement the reference count of a value and delete
    #	the value if it has ceased to be used.
    #
    # Parameters:
    #	value -	The IMPURE EMPTY DICT LLVM value reference for the operand.
    #
    # Results:
    #	None.

    method dropReference(IMPURE\040EMPTY\040DICT) {value} {
	my Call tcl.dropReference $value
	return
    }

    # Builder:dropReference(IMPURE EMPTY LIST) --
    #
    #	Generate code to decrement the reference count of a value and delete
    #	the value if it has ceased to be used.
    #
    # Parameters:
    #	value -	The IMPURE EMPTY LIST LLVM value reference for the operand.
    #
    # Results:
    #	None.

    method dropReference(IMPURE\040EMPTY\040LIST) {value} {
	my Call tcl.dropReference $value
	return
    }

    # Builder:dropReference(STRING) --
    #
    #	Generate code to decrement the reference count of a value and delete
    #	the value if it has ceased to be used.
    #
    # Parameters:
................................................................................

    method instanceOf.ZEROONE_BOOLEAN(STRING) {value {name ""}} {
	my call ${tcl.isZeroOneBoolean} [list $value [Const false bool]] $name
    }
    method instanceOf.IMPURE_ZEROONE_BOOLEAN(STRING) {value {name ""}} {
	my call ${tcl.isZeroOneBoolean} [list $value [Const false bool]] $name
    }

    # Builder:instanceOf.DICT --
    #
    #	Generate code to check if the given STRING contains something that can
    #	be parsed to get a DICT.

    method instanceOf.DICT(STRING) {value {name ""}} {
	my call ${tcl.isDict} [list $value] $name
    }
    method instanceOf.IMPURE_DICT(STRING) {value {name ""}} {
	my call ${tcl.isDict} [list $value] $name
    }

    # Builder:instanceOf.LIST --
    #
    #	Generate code to check if the given STRING contains something that
    #	can be parsed to get a LIST.

    method instanceOf.LIST(STRING) {value {name ""}} {
	my call ${tcl.isList} [list $value] $name
    }
    method instanceOf.IMPURE_LIST(STRING) {value {name ""}} {
	my call ${tcl.isList} [list $value] $name
    }

    # Builder:int --
    #
    #	Generate code to create an integer "literal".
    #
    # Parameters:
    #	value -	The Tcl integer that we are converting to an LLVM INT.
................................................................................
	if {[string match "* NEXIST" $type]} {
	    set type [string range $type 0 end-7]
	} elseif {[string match "NEXIST *" $type]} {
	    set type [string range $type 7 end]
	}
	my insert [my undef $type!] [Const true bool] 0 $name
    }

    # Builder:narrowToType.LIST(STRING) --
    #
    #	Generate code to parse the given STRING and extract a LIST. The
    #	STRING is already be known to contain a value of the right type (due
    #	to higher-level quadcode constraints). Quadcode implementation
    #	('narrowToType').
    #
    # Parameters:
    #	value -	The STRING LLVM value reference to parse.
    #	name (optional) -
    #		A name to give to the result value.
    #
    # Results:
    #	A DOUBLE LLVM value reference.

    method narrowToType.LIST(STRING) {value {name ""}} {
	return $value
    }
    method narrowToType.IMPURE_LIST(STRING) {value {name ""}} {
	return $value
    }
    method narrowToType.EMPTY_LIST(STRING) {value {name ""}} {
	return $value
    }
    method narrowToType.IMPURE_EMPTY_LIST(STRING) {value {name ""}} {
	return $value
    }

    # Builder:unmaybe --
    #
    #	Get the value out of a FAIL or NEXIST. NOTE: The FAIL/NEXIST must be a
    #	Just or the result will be an 'undef'; test with the 'maybe' method
    #	first!
    #
................................................................................
    #	Returns an LLVM IMPURE NUMERIC value

    method packImpure(NUMERIC) {value {name ""}} {
	set sval [my stringify(NUMERIC) $value]
	my addReference(STRING) $sval
	return [my impure NUMERIC $sval $value $name]
    }

    # Builder:packImpure(DICT) --
    #
    #	Convert a DICT to an IMPURE DICT
    #
    # Parameters:
    #	value -	LLVM Value to pack into the 'impure' structure
    #	name (optional) -
    #		A name to give to the result value.
    #
    # Results:
    #	Returns an LLVM IMPURE DICT value

    method packImpure(DICT) {value {name ""}} {
	return $value
    }

    # Builder:packImpure(EMPTY DICT) --
    #
    #	Convert an EMPTY DICT to an IMPURE EMPTY DICT
    #
    # Parameters:
    #	value -	LLVM Value to pack into the 'impure' structure
    #	name (optional) -
    #		A name to give to the result value.
    #
    # Results:
    #	Returns an LLVM IMPURE DICT value

    method packImpure(EMPTY\040DICT) {value {name ""}} {
	return $value
    }

    # Builder:packImpure(EMPTY LIST) --
    #
    #	Convert an EMPTY LIST to an IMPURE EMPTY LIST
    #
    # Parameters:
    #	value -	LLVM Value to pack into the 'impure' structure
    #	name (optional) -
    #		A name to give to the result value.
    #
    # Results:
    #	Returns an LLVM IMPURE LIST value

    method packImpure(EMPTY\040LIST) {value {name ""}} {
	return $value
    }

    # Builder:packImpure(LIST) --
    #
    #	Convert a LIST to an IMPURE LIST
    #
    # Parameters:
    #	value -	LLVM Value to pack into the 'impure' structure
    #	name (optional) -
    #		A name to give to the result value.
    #
    # Results:
    #	Returns an LLVM IMPURE LIST value

    method packImpure(LIST) {value {name ""}} {
	return $value
    }

    # Builder:packImpure(ZEROONE BOOLEAN) --
    #
    #	Convert a ZEROONE BOOLEAN to an IMPURE ZEROONE BOOLEAN
    #
    # Parameters:
    #	value -	LLVM Value to pack into the 'impure' structure

Changes to codegen/compile.tcl.

364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
...
667
668
669
670
671
672
673
674

675
676
677
678

679

680
681
682
683
684
685
686
...
688
689
690
691
692
693
694
695

696
697
698
699
700
701
702
703
704
705
706
707
....
1464
1465
1466
1467
1468
1469
1470






1471
1472
1473
1474
1475
1476
1477
			my Warn "default injection for parameter %d of '%s'; injecting '%s'" \
			    [expr {$idx + 1}] [GetValueName [$func ref]] $defaultvalue
			set var [my LoadTypedLiteral $defaultvalue $type]
		    } else {
			set var [$func param $idx $name]
		    }
		    set variables($tgt) $var
		    if {[regexp {^IMPURE } $type]} {
			set var [$b stringifyImpure $var]
			set type STRING
		    }
		    if {refType($type)} {
			$b printref $var "param:"
			$b addReference($type) $var
			$b assume [$b shared $var]
................................................................................
		    append opcode ( [my ValueTypes $src] )
		    set src [my LoadOrLiteral $src]
		    my StoreResult $tgt [$b $opcode $src $name]
		}
		"purify" {
		    lassign $l opcode tgt src
		    set value [my LoadOrLiteral $src]
		    if {![regexp {^IMPURE} [my OperandType $src]]} {

			return -code error \
			    "Trying to purify something that is not impure"
		    }
		    set name [my LocalVarName $tgt]

		    set value [$b impure.value $value $name]

		    set type [my OperandType $tgt]
		    if {refType($type)} {
			$b addReference($type) $value
			$b printref $value "purify:"
		    }
		    my StoreResult $tgt $value
		}
................................................................................
		    lassign $l opcode tgt src
		    set type [my OperandType $src]
		    if {$src ni $consumed} {
			if {$type eq "VOID"} {
			    # VOID is trivial to free
			} elseif {refType($type)} {
			    $b printref $variables($src) "free:"
			    if {"ARRAY" in [my ValueTypes $src]} {

				# TRICKY POINT: need variable name to unset an array
				set name [Const [my LocalVarName $tgt] STRING]
				$b dropReference([my ValueTypes $src]) $variables($src) $name
			    } else {
				$b dropReference([my ValueTypes $src]) $variables($src)
			    }
			}
			lappend consumed $src
		    }
		}
		"exists" {
		    lassign $l opcode tgt src
................................................................................
		set tuple [$b arraystring.from.array $value]
	    } else {
		set svalue [my WidenedValue $value $srctype STRING]
		set tuple [$b arraystring.from.scalar $svalue]
	    }
	    return $tuple
	}







	# IMPURE to IMPURE - Copy the string value, and promote the
	# inner value

	if {[lindex $tgttype 0] eq "IMPURE"
		&& [lindex $srctype 0] eq "IMPURE"} {
	    set itgttype [lrange $tgttype 1 end]






|







 







|
>




>
|
>







 







|
>


|

|







 







>
>
>
>
>
>







364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
...
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
...
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
....
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
			my Warn "default injection for parameter %d of '%s'; injecting '%s'" \
			    [expr {$idx + 1}] [GetValueName [$func ref]] $defaultvalue
			set var [my LoadTypedLiteral $defaultvalue $type]
		    } else {
			set var [$func param $idx $name]
		    }
		    set variables($tgt) $var
		    if {[regexp {^IMPURE } $type] && "LIST" ni $type && "DICT" ni $type} {
			set var [$b stringifyImpure $var]
			set type STRING
		    }
		    if {refType($type)} {
			$b printref $var "param:"
			$b addReference($type) $var
			$b assume [$b shared $var]
................................................................................
		    append opcode ( [my ValueTypes $src] )
		    set src [my LoadOrLiteral $src]
		    my StoreResult $tgt [$b $opcode $src $name]
		}
		"purify" {
		    lassign $l opcode tgt src
		    set value [my LoadOrLiteral $src]
		    set srctype [my OperandType $src]
		    if {"IMPURE" ni $srctype} {
			return -code error \
			    "Trying to purify something that is not impure"
		    }
		    set name [my LocalVarName $tgt]
		    if {"LIST" ni $srctype && "DICT" ni $srctype} {
			set value [$b impure.value $value $name]
		    }
		    set type [my OperandType $tgt]
		    if {refType($type)} {
			$b addReference($type) $value
			$b printref $value "purify:"
		    }
		    my StoreResult $tgt $value
		}
................................................................................
		    lassign $l opcode tgt src
		    set type [my OperandType $src]
		    if {$src ni $consumed} {
			if {$type eq "VOID"} {
			    # VOID is trivial to free
			} elseif {refType($type)} {
			    $b printref $variables($src) "free:"
			    set vt [my ValueTypes $src]
			    if {"ARRAY" in $vt} {
				# TRICKY POINT: need variable name to unset an array
				set name [Const [my LocalVarName $tgt] STRING]
				$b dropReference($vt) $variables($src) $name
			    } else {
				$b dropReference($vt) $variables($src)
			    }
			}
			lappend consumed $src
		    }
		}
		"exists" {
		    lassign $l opcode tgt src
................................................................................
		set tuple [$b arraystring.from.array $value]
	    } else {
		set svalue [my WidenedValue $value $srctype STRING]
		set tuple [$b arraystring.from.scalar $svalue]
	    }
	    return $tuple
	}

	# Variations of LIST and DICT go straight to STRING

	if {"STRING" in $tgttype && ("LIST" in $srctype || "DICT" in $srctype)} {
	    return $value
	}

	# IMPURE to IMPURE - Copy the string value, and promote the
	# inner value

	if {[lindex $tgttype 0] eq "IMPURE"
		&& [lindex $srctype 0] eq "IMPURE"} {
	    set itgttype [lrange $tgttype 1 end]

Changes to codegen/stdlib.tcl.

36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
....
2038
2039
2040
2041
2042
2043
2044


















2045
2046
2047
2048
2049
2050
2051
    variable tcl.resolveCmd tcl.originCmd

    # Variables holding implementations of Tcl's list operators
    variable tcl.list.create tcl.list.length tcl.list.append tcl.list.concat
    variable tcl.list.foreach.getStep tcl.list.foreach.mayStep
    variable tcl.list.foreach.nextStep tcl.list.foreach.start.step
    variable tcl.list.foreach.start.finish tcl.list.unshare
    variable tcl.list.range tcl.list.range1 tcl.list.in
    variable tcl.list.index tcl.list.index1 tcl.list.indexList
    variable tcl.list.set tcl.list.set1 tcl.list.setList tcl.list.verify

    # Variables holding implementations of Tcl's dict operators
    variable tcl.dict.get1 tcl.dict.get tcl.dict.set1 tcl.dict.set
    variable tcl.dict.exists1 tcl.dict.exists tcl.dict.unset1 tcl.dict.unset
    variable tcl.dict.iterStart tcl.dict.iterNext tcl.dict.iterDone
................................................................................
	    set call [my Call $func $obj $new]
	    AddCallAttribute $call 1 nocapture
	    AddCallAttribute $call 2 nocapture
	    my ret $new
	label fail:
	    my ret [my null STRING]
	}



















	##### Function tcl.list.create #####
	#
	# Type signature: objc:int * objv:STRING* -> STRING
	#
	# Core of quadcode implementation ('list')
	#






|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
....
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
    variable tcl.resolveCmd tcl.originCmd

    # Variables holding implementations of Tcl's list operators
    variable tcl.list.create tcl.list.length tcl.list.append tcl.list.concat
    variable tcl.list.foreach.getStep tcl.list.foreach.mayStep
    variable tcl.list.foreach.nextStep tcl.list.foreach.start.step
    variable tcl.list.foreach.start.finish tcl.list.unshare
    variable tcl.list.range tcl.list.range1 tcl.list.in tcl.isList
    variable tcl.list.index tcl.list.index1 tcl.list.indexList
    variable tcl.list.set tcl.list.set1 tcl.list.setList tcl.list.verify

    # Variables holding implementations of Tcl's dict operators
    variable tcl.dict.get1 tcl.dict.get tcl.dict.set1 tcl.dict.set
    variable tcl.dict.exists1 tcl.dict.exists tcl.dict.unset1 tcl.dict.unset
    variable tcl.dict.iterStart tcl.dict.iterNext tcl.dict.iterDone
................................................................................
	    set call [my Call $func $obj $new]
	    AddCallAttribute $call 1 nocapture
	    AddCallAttribute $call 2 nocapture
	    my ret $new
	label fail:
	    my ret [my null STRING]
	}

	##### Function tcl.isList #####
	#
	# Type signature: objPtr:STRING -> int1
	#
	# Part of quadcode implementation ('isInstance')
	#
	# Wrapper around Tcl_ListObjLength that uses it to do a list-ness
	# check.

	set f [$m local "tcl.isList" int1<-STRING]
	params objPtr
	build {
	    nonnull $objPtr
	    set var [my alloc int "length"]
	    set code [$api Tcl_ListObjLength {} $objPtr $var]
	    my ret [my eq $code $0]
	}

	##### Function tcl.list.create #####
	#
	# Type signature: objc:int * objv:STRING* -> STRING
	#
	# Core of quadcode implementation ('list')
	#

Changes to codegen/struct.tcl.

2943
2944
2945
2946
2947
2948
2949


2950
2951


2952
2953
2954
2955
2956
2957


2958
2959


2960
2961
2962
2963
2964
2965
2966
2967


2968
2969


2970
2971
2972
2973
2974
2975

2976
2977

2978
2979
2980
2981
2982
2983
2984
2985



2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
    #	FOLLOWS STANDARD TclOO PROTOCOL
    #
    # Side effects:
    # 	May create a method. May perform a tailcall (beware if attempting to
    # 	wrap with a filter!)

    method unknown {methodName args} {


	if {[regexp {^addReference\(FAIL[ _]IMPURE (.*)\)$} \
		 $methodName -> utype]} {


	    oo::objdefine [self] method $methodName {value} \
		[string map [list @utype $utype] {
		    set sval [my impure.string [my unmaybe $value]]
		    my impure.maybeAddReference [my maybe $value] $sval
		}]
	    tailcall my $methodName {*}$args


	} elseif {[regexp {^dropReference\(FAIL[ _]IMPURE[ _](.*)\)$} \
		       $methodName -> utype]} {


	    oo::objdefine [self] method $methodName {value} \
		[string map [list @utype $utype] {
		    my select [my maybe $value] \
			[Const false bool] \
			[my addReference(STRING) \
			     [my impure.string [my unmaybe $value]]]
		}]
	    tailcall my $methodName {*}$args


	} elseif {[regexp {^addReference\(IMPURE[ _](.*)\)$} \
		       $methodName -> utype]} {


	    oo::objdefine [self] method $methodName {value} \
		[string map [list @utype $utype] {
		    my addReference(STRING) [my impure.string $value]
		}]
	    tailcall my $methodName {*}$args


	} elseif {[regexp {^dropReference\(IMPURE[ _](.*)\)$} $methodName \
		       -> utype]} {

	    oo::objdefine [self] method $methodName {value} \
		[string map [list @utype $utype] {
		    my dropReference(STRING) [my impure.string $value]
		    # How to determine whether the underlying type is
		    # itself a reference type? (Maybe never?)
		    #my {dropReference(@utype)} [my impure.value $value]
		}]
	    tailcall my $methodName {*}$args



	} elseif {[my MakeTypecastWrapper $methodName]} {
	    set v [my $methodName {*}$args]
	    return $v
	}
	next $methodName {*}$args
    }
    unexport unknown

    # Builder:MakeTypecastWrapper --
    #






>
>
|
<
>
>
|
|
|
|
|
|
>
>
|
<
>
>
|
|
|
|
|
|
|
|
>
>
|
<
>
>
|
|
|
|
|
|
>
|
|
>
|
|
|
|
|
|
|
|
>
>
>
|
|
<







2943
2944
2945
2946
2947
2948
2949
2950
2951
2952

2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963

2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976

2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001

3002
3003
3004
3005
3006
3007
3008
    #	FOLLOWS STANDARD TclOO PROTOCOL
    #
    # Side effects:
    # 	May create a method. May perform a tailcall (beware if attempting to
    # 	wrap with a filter!)

    method unknown {methodName args} {
	set BASIC_REFTYPES {STRING LIST {EMPTY LIST} DICT {EMPTY DICT}}
	switch -regexp -matchvar match -- $methodName {
	    {^addReference\(FAIL[ _]IMPURE (.*)\)$} {

		lassign $match -> utype
		if {$utype ni $BASIC_REFTYPES} {
		    oo::objdefine [self] method $methodName {value} \
			[string map [list @utype $utype] {
			    set sval [my impure.string [my unmaybe $value]]
			    my impure.maybeAddReference [my maybe $value] $sval
			}]
		    tailcall my $methodName {*}$args
		}
	    }
	    {^dropReference\(FAIL[ _]IMPURE[ _](.*)\)$} {

		lassign $match -> utype
		if {$utype ni $BASIC_REFTYPES} {
		    oo::objdefine [self] method $methodName {value} \
			[string map [list @utype $utype] {
			    my select [my maybe $value] \
				[Const false bool] \
				[my addReference(STRING) \
				     [my impure.string [my unmaybe $value]]]
			}]
		    tailcall my $methodName {*}$args
		}
	    }
	    {^addReference\(IMPURE[ _](.*)\)$} {

		lassign $match -> utype
		if {$utype ni $BASIC_REFTYPES} {
		    oo::objdefine [self] method $methodName {value} \
			[string map [list @utype $utype] {
			    my addReference(STRING) [my impure.string $value]
			}]
		    tailcall my $methodName {*}$args
		}
	    }
	    {^dropReference\(IMPURE[ _](.*)\)$} {
		lassign $match -> utype
		if {$utype ni $BASIC_REFTYPES} {
		    oo::objdefine [self] method $methodName {value} \
			[string map [list @utype $utype] {
			    my dropReference(STRING) [my impure.string $value]
			    # How to determine whether the underlying type is
			    # itself a reference type? (Maybe never?)
			    #my {dropReference(@utype)} [my impure.value $value]
			}]
		    tailcall my $methodName {*}$args
		}
	    }
	}
	if {[my MakeTypecastWrapper $methodName]} {
	    tailcall my $methodName {*}$args

	}
	next $methodName {*}$args
    }
    unexport unknown

    # Builder:MakeTypecastWrapper --
    #

Changes to codegen/thunk.tcl.

470
471
472
473
474
475
476

477

478
479

480
481
482
483
484
485
486
	    $b condBr [$b maybe $result] $isFail $next
	    $isFail build $b {
		$b ret [$b extract $result 0]
	    }
	    $next build-in $b
	    set result [$b unmaybe $result]
	}

	if {[regexp "^IMPURE (.*)" $resultType]} {

	    set result [$b impure.string $result]
	    SetValueName $result @result

	    set resultType STRING
	}
	upvar 0 thunk.result.$resultType thunkResultMapper
	if {![info exist thunkResultMapper]} {
	    error "unhandled result type: $resultType"
	}
	$b call $thunkResultMapper [list $interp $result]






>
|
>
|
|
>







470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
	    $b condBr [$b maybe $result] $isFail $next
	    $isFail build $b {
		$b ret [$b extract $result 0]
	    }
	    $next build-in $b
	    set result [$b unmaybe $result]
	}
	set resultType [string map {{EMPTY STRING} STRING} [string map {DICT STRING LIST STRING} $resultType]]
	if {[regexp "^IMPURE (.*)" $resultType -> payload]} {
	    if {$payload ne "STRING"} {
		set result [$b impure.string $result]
		SetValueName $result @result
	    }
	    set resultType STRING
	}
	upvar 0 thunk.result.$resultType thunkResultMapper
	if {![info exist thunkResultMapper]} {
	    error "unhandled result type: $resultType"
	}
	$b call $thunkResultMapper [list $interp $result]

Changes to demos/perftest/tester.tcl.

1963
1964
1965
1966
1967
1968
1969














1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
....
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
    expr {wide($x)}
}
 
# A simple helper that is not compiled, but rather just shortens code below

proc cleanopt {script} {
    variable cleanopt














    set code [uplevel 1 [list catch $script cleanopt(msg) cleanopt(opt)]]
    set msg $cleanopt(msg)
    set opt $cleanopt(opt)
    if {[dict exists $opt -during]} {
	dict set opt -during [lsort -stride 2 -dictionary -index 0 \
				  [dict remove [dict get $opt -during] \
				       -during -errorinfo -errorstack]]
    }
    list $code $msg [lsort -stride 2 -dictionary -index 0 \
			 [dict remove $opt -errorinfo -errorstack]]
}
 
#########################################################################
#
# List of demonstration scripts. Each of these will be executed before and
# after having the compilation engine applied; the output values from before
# and after will be compared, and if they match, the performance ratio will be
................................................................................
    {expandtest::test1}
    {expandtest::test2}
    {expandtest::test3}
    # {expandtest::test5}   Needs support for loop exception ranges
    {expandtest::test6 {a b c d e} {2 2} x}
    {expandtest::test7}
    {expandtest::test8}
    {cleanopt {expandtest::test9}}
    {cleanopt {expandtest::test10}}
    {cleanopt {expandtest::test11}}
    {cleanopt {expandtest::test12}}

    {bug-0616bcf08e::msrange 0 10}
    {bug-0616bcf08e::msrange2 0 10}
    {singleton::lforeach}
    {singleton::llindex}
    {singleton::srange}
    {qsort {3 6 8 7 0 1 4 2 9 5}}






>
>
>
>
>
>
>
>
>
>
>
>
>
>





|
<


|







 







|
|
|
|







1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989

1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
....
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
    expr {wide($x)}
}
 
# A simple helper that is not compiled, but rather just shortens code below

proc cleanopt {script} {
    variable cleanopt
    set badopts {-errorinfo -errorstack}
    set code [uplevel 1 [list catch $script cleanopt(msg) cleanopt(opt)]]
    set msg $cleanopt(msg)
    set opt $cleanopt(opt)
    if {[dict exists $opt -during]} {
	dict set opt -during [lsort -stride 2 -dictionary -index 0 \
		[dict remove [dict get $opt -during] -during {*}$badopts]]
    }
    list $code $msg [lsort -stride 2 -dictionary -index 0 \
	    [dict remove $opt {*}$badopts]]
}
proc cleaneropt {script} {
    variable cleanopt
    set badopts {-errorinfo -errorstack -errorline -errorcode}
    set code [uplevel 1 [list catch $script cleanopt(msg) cleanopt(opt)]]
    set msg $cleanopt(msg)
    set opt $cleanopt(opt)
    if {[dict exists $opt -during]} {
	dict set opt -during [lsort -stride 2 -dictionary -index 0 \
		[dict remove [dict get $opt -during] -during {*}$badopts]]

    }
    list $code $msg [lsort -stride 2 -dictionary -index 0 \
	    [dict remove $opt {*}$badopts]]
}
 
#########################################################################
#
# List of demonstration scripts. Each of these will be executed before and
# after having the compilation engine applied; the output values from before
# and after will be compared, and if they match, the performance ratio will be
................................................................................
    {expandtest::test1}
    {expandtest::test2}
    {expandtest::test3}
    # {expandtest::test5}   Needs support for loop exception ranges
    {expandtest::test6 {a b c d e} {2 2} x}
    {expandtest::test7}
    {expandtest::test8}
    {cleaneropt {expandtest::test9}}
    {cleaneropt {expandtest::test10}}
    {cleaneropt {expandtest::test11}}
    {cleaneropt {expandtest::test12}}

    {bug-0616bcf08e::msrange 0 10}
    {bug-0616bcf08e::msrange2 0 10}
    {singleton::lforeach}
    {singleton::llindex}
    {singleton::srange}
    {qsort {3 6 8 7 0 1 4 2 9 5}}

Changes to quadcode/types.tcl.

922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942


943
944
945
946
947
948
949
	if {$y eq $x} {
	    return $dataType::DOUBLE
	} else {
	    return [dataType::typeUnion $dataType::DOUBLE $dataType::IMPURE]
	}
    } elseif {[string is boolean -strict $x]} {
	return [dataType::typeUnion $dataType::BOOLEAN $dataType::IMPURE]
    } elseif {[string is list $x]} {
	# Purity is determined by seeing if the string value could be made by
	# [list]; if not, we've got a value with extra whitespace we should
	# preserve.
	set impurity [expr {($x eq [list {*}$x]) * $dataType::IMPURE}]
	# Odd-length LISTs cannot be DICTs
	if {[llength $x] & 1} {
	    return [expr {$dataType::LIST | $impurity}]
	}
	# We only claim a constant is a DICT if its keys are unique
	if {[dict create {*}$x] eq [list {*}$x]} {
	    return [expr {$dataType::DICT | $impurity}]
	} else {
	    return [expr {$dataType::LIST | $impurity}]


	}
    } else {
	return $dataType::IMPUREOTHERSTRING
    }
}
 
# builtinCommandType -






|



|
|
|
|
|
|
|
|
|
|
>
>







922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
	if {$y eq $x} {
	    return $dataType::DOUBLE
	} else {
	    return [dataType::typeUnion $dataType::DOUBLE $dataType::IMPURE]
	}
    } elseif {[string is boolean -strict $x]} {
	return [dataType::typeUnion $dataType::BOOLEAN $dataType::IMPURE]
    } elseif {[string is list $x] && ($x eq [list {*}$x])} {
	# Purity is determined by seeing if the string value could be made by
	# [list]; if not, we've got a value with extra whitespace we should
	# preserve.

	# We claim that lists of length one are simple STRINGs; that's usually
	# a more honest choice.
	if {[llength $x] <= 1} {
	    return $dataType::IMPUREOTHERSTRING
	}
	# Odd-length LISTs cannot be DICTs, and we prefer to not call them
	# DICTs if they have non-unique keys.
	if {[llength $x] & 1 == 0 && [dict create {*}$x] eq [list {*}$x]} {
	    return $dataType::NONEMPTYDICT
	} else {
	    return $dataType::NONDICTLIST
	}
    } else {
	return $dataType::IMPUREOTHERSTRING
    }
}
 
# builtinCommandType -