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: |
0ec315adace678fd9af1a9db3ad71baa |
| 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 -
|