tclquadcode

Check-in [a18c116f4c]
Login

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

Overview
Comment:Add support for shifts and incrScalar1
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:a18c116f4c4cadb8ad14bad36f822bdaedea6fc4
User & Date: dkf 2015-02-01 15:38:07
Context
2015-03-14
17:04
Merge lifetime management instruction generation. check-in: 11539b38e2 user: dkf tags: trunk
2015-03-08
02:01
Added logic to free values that will no longer be used. Results in a new quadcode instruction, 'free', whose input parameter is the value to be dismissed. check-in: 32281c70dd user: kbk tags: kbk-free-values
2015-02-01
15:38
merge trunk check-in: 61d12ac5d5 user: dkf tags: llvm-integration
15:38
Add support for shifts and incrScalar1 check-in: a18c116f4c user: dkf tags: trunk
15:36
Support the incrScalar1 instruction. check-in: 05b465c309 user: dkf tags: llvm-integration
2015-01-31
20:18
Reduce the size of writesOneOf, to eke out a tiny bit more speed. check-in: 8748b36d1b user: kbk tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to codegen.build.tcl.

75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
...
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
...
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
...
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
...
217
218
219
220
221
222
223



224
225
226
227
228
229
230

















231
232
233
234
235
236
237
238
239
240
...
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
	set x_32 [my int.32 $x "x.32"]
	set y_32 [my int.32 $y "y.32"]
	set z_32_ov [my call [$m intrinsic $intrinsic $i32] \
			 [list $x_32 $y_32]]
	set 32overflow [$f block]
	set 32small [$f block]
	# Note that we expect overflow to be *rare*; put the hint in
	set bit [Type bool]
	my condBr [my call [$m intrinsic expect $bit] \
		       [list [my extract $z_32_ov 1] [ConstInt $bit 0 0]]] \
	    $32overflow $32small

	my @end $32overflow
	set x_64 [BuildSExt $b $x_32 $i64 "x.64"]
	set y_64 [BuildSExt $b $y_32 $i64 "x.64"]
	my ret [my packInt64 [Build$normal $b $x_64 $y_64 "z.64"]]

	my @end $32small
	my ret [my packInt32 [my extract $z_32_ov 0 "z.32"]]

	my @end $64bit
	set x_64 [my call ${tcl.int.64} [list $x] "x.64"]
	set y_64 [my call ${tcl.int.64} [list $y] "y.64"]
	my ret [my packInt64 [Build$normal $b $x_64 $y_64 "z.64"]]

	set [my varname $name] [$f ref]
	return $f
    }

    method NonGrowingBinaryFunction {m name normal {correction {}}} {
................................................................................
	set y [my int.32 $y_struct "y.32"]
	set z [Build$normal $b $x $y "z.32"]
	set width 32
	eval $correction
	my ret [my packInt32 $z]

	my @end $64bit
	set x [my call ${tcl.int.64} [list $x_struct] "x.64"]
	set y [my call ${tcl.int.64} [list $y_struct] "y.64"]
	set z [Build$normal $b $x $y "z.64"]
	set width 64
	eval $correction
	my ret [my packInt64 $z]

	set [my varname $name] [$f ref]
	return $f
................................................................................
	my @end $32bit
	set x_32 [my int.32 $x "x.32"]
	set y_32 [my int.32 $y "y.32"]
	set z_bit [BuildICmp $b LLVMInt$comparator $x_32 $y_32 "z.bit"]
	my ret [my packInt32 [BuildZExt $b $z_bit [Type int] "z.32"]]

	my @end $64bit
	set x_64 [my call ${tcl.int.64} [list $x] "x.64"]
	set y_64 [my call ${tcl.int.64} [list $y] "y.64"]
	set z_bit [BuildICmp $b LLVMInt$comparator $x_64 $y_64 "z.bit"]
	my ret [my packInt32 [BuildZExt $b $z_bit [Type int] "z.32"]]

	set [my varname $name] [$f ref]
	return $f
    }

................................................................................
	set z_64 [Build$normal $b $x_64 "z.64"]
	my ret [my packInt64 $z_64]

	set [my varname $name] [$f ref]
	return $f
    }

    method getInt64 {INT {name ""}} {
	my call ${tcl.int.64} [list $INT] $name
    }

    variable tcl.int.64
    variable tcl.add tcl.sub tcl.mul tcl.shl
    variable tcl.div tcl.mod tcl.shr tcl.and tcl.or tcl.xor
    variable tcl.eq tcl.ne tcl.lt tcl.le tcl.gt tcl.ge
    variable tcl.not tcl.neg tcl_div
    method @supportFunctions {m} {
	set f [$m function.create tcl.int.64 [Type func{int64<-INT}]]
................................................................................
	set x64 [$f block]
	my condBr [my isInt32 $x] $x32 $x64
	my @end $x32
	my ret [BuildSExt $b [my int.32 $x] [Type int64] ""]
	my @end $x64
	my ret [my int.64 $x]
	set tcl.int.64 [$f ref]




	set f [$m function.create tcl.shl [Type func{INT<-INT,INT}]]
	$f private
	$f attribute AlwaysInline ReadNone
	my @end [$f block]
	set x [$f param 0 "x"]
	set y [$f param 1 "y"]

















	set x64 [my call ${tcl.int.64} [list $x]]
	set y64 [my call ${tcl.int.64} [list $y]]
	my ret [my packInt64 [BuildShl $b $x64 $y64 ""]]; # FIXME
	set tcl.shl [$f ref]

	foreach width {32 64} type {int int64} {
	    set f [$m function.create tcl.div.$width [Type func{$type<-$type,$type}]]
	    $f private
	    $f attribute AlwaysInline ReadOnly
	    set tcl_div($width) [$f ref]
................................................................................
	BuildCall $b $function $arguments $name
    }

    method cast(BOOLEAN) {value {name ""}} {
	BuildIntCast $b $value [Type "INT BOOLEAN"] $name
    }
    method cast(DOUBLE) {value {name ""}} {
	set realvalue [my call ${tcl.int.64} [list $value]]
	BuildSIToFP $b $realvalue [Type DOUBLE] $name
    }
    method cast(INT) {value {name ""}} {
	# FIXME detect out-of-range values?
	my packInt32 [BuildFPToSI $b $value [Type int] ""] $name
    }
    method cast(int) {value {name ""}} {
	BuildIntCast $b $value [Type int] $name
    }
    method cast(ptr) {value type {name ""}} {
	BuildPointerCast $b $value [Type $type*] $name
    }

    method condBr(INT) {cond true false} {
	set realcond [my call ${tcl.int.64} [list $cond]]
	set realcond [BuildICmp $b LLVMIntNE $realcond \
			  [ConstInt [Type int64] 0 0] ""]
	BuildCondBr $b $realcond [$true ref] [$false ref]
    }
    method condBr {cond true false} {
	BuildCondBr $b $cond [$true ref] [$false ref]
    }

    method constString {content {name "string.constant"}} {







<
|
|











|
|







 







|
|







 







|
|







 







<
<
<
<







 







>
>
>







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







 







|
<













|
|
<







75
76
77
78
79
80
81

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
...
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
...
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
...
193
194
195
196
197
198
199




200
201
202
203
204
205
206
...
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
...
386
387
388
389
390
391
392
393

394
395
396
397
398
399
400
401
402
403
404
405
406
407
408

409
410
411
412
413
414
415
	set x_32 [my int.32 $x "x.32"]
	set y_32 [my int.32 $y "y.32"]
	set z_32_ov [my call [$m intrinsic $intrinsic $i32] \
			 [list $x_32 $y_32]]
	set 32overflow [$f block]
	set 32small [$f block]
	# Note that we expect overflow to be *rare*; put the hint in

	my condBr [my call [$m intrinsic expect [Type bool]] \
		       [list [my extract $z_32_ov 1] [Const false bool]]] \
	    $32overflow $32small

	my @end $32overflow
	set x_64 [BuildSExt $b $x_32 $i64 "x.64"]
	set y_64 [BuildSExt $b $y_32 $i64 "x.64"]
	my ret [my packInt64 [Build$normal $b $x_64 $y_64 "z.64"]]

	my @end $32small
	my ret [my packInt32 [my extract $z_32_ov 0 "z.32"]]

	my @end $64bit
	set x_64 [my getInt64 $x "x.64"]
	set y_64 [my getInt64 $y "y.64"]
	my ret [my packInt64 [Build$normal $b $x_64 $y_64 "z.64"]]

	set [my varname $name] [$f ref]
	return $f
    }

    method NonGrowingBinaryFunction {m name normal {correction {}}} {
................................................................................
	set y [my int.32 $y_struct "y.32"]
	set z [Build$normal $b $x $y "z.32"]
	set width 32
	eval $correction
	my ret [my packInt32 $z]

	my @end $64bit
	set x [my getInt64 $x_struct "x.64"]
	set y [my getInt64 $y_struct "y.64"]
	set z [Build$normal $b $x $y "z.64"]
	set width 64
	eval $correction
	my ret [my packInt64 $z]

	set [my varname $name] [$f ref]
	return $f
................................................................................
	my @end $32bit
	set x_32 [my int.32 $x "x.32"]
	set y_32 [my int.32 $y "y.32"]
	set z_bit [BuildICmp $b LLVMInt$comparator $x_32 $y_32 "z.bit"]
	my ret [my packInt32 [BuildZExt $b $z_bit [Type int] "z.32"]]

	my @end $64bit
	set x_64 [my getInt64 $x "x.64"]
	set y_64 [my getInt64 $y "y.64"]
	set z_bit [BuildICmp $b LLVMInt$comparator $x_64 $y_64 "z.bit"]
	my ret [my packInt32 [BuildZExt $b $z_bit [Type int] "z.32"]]

	set [my varname $name] [$f ref]
	return $f
    }

................................................................................
	set z_64 [Build$normal $b $x_64 "z.64"]
	my ret [my packInt64 $z_64]

	set [my varname $name] [$f ref]
	return $f
    }





    variable tcl.int.64
    variable tcl.add tcl.sub tcl.mul tcl.shl
    variable tcl.div tcl.mod tcl.shr tcl.and tcl.or tcl.xor
    variable tcl.eq tcl.ne tcl.lt tcl.le tcl.gt tcl.ge
    variable tcl.not tcl.neg tcl_div
    method @supportFunctions {m} {
	set f [$m function.create tcl.int.64 [Type func{int64<-INT}]]
................................................................................
	set x64 [$f block]
	my condBr [my isInt32 $x] $x32 $x64
	my @end $x32
	my ret [BuildSExt $b [my int.32 $x] [Type int64] ""]
	my @end $x64
	my ret [my int.64 $x]
	set tcl.int.64 [$f ref]
	my closure getInt64 {INT {resultName ""}} {
	    my call [$f ref] [list $INT] $resultName
	}

	set f [$m function.create tcl.shl [Type func{INT<-INT,INT}]]
	$f private
	$f attribute AlwaysInline ReadNone
	my @end [$f block]
	set x [$f param 0 "x"]
	set y [$f param 1 "y"]
	set 32bit [$f block]
	set whatabouty [$f block]
	set confirmspace [$f block]
	set 64bit [$f block]
	my condBr [my isInt32 $x] $whatabouty $64bit
	my @end $whatabouty
	my condBr [my isInt32 $y] $confirmspace $64bit
	my @end $confirmspace
	set x32 [my int.32 $x]
	set y32 [my int.32 $y]
	set ctlz [$m intrinsic ctlz [Type int]]
	set false [Const false bool]
	set sparebits [my call $ctlz [list $x32 $false]]
	my condBr [my gt $sparebits $y32] $32bit $64bit
	my @end $32bit
	my ret [my packInt32 [BuildShl $b $x32 $y32 ""]]
	my @end $64bit
	set x64 [my getInt64 $x]
	set y64 [my getInt64 $y]
	my ret [my packInt64 [BuildShl $b $x64 $y64 ""]]
	set tcl.shl [$f ref]

	foreach width {32 64} type {int int64} {
	    set f [$m function.create tcl.div.$width [Type func{$type<-$type,$type}]]
	    $f private
	    $f attribute AlwaysInline ReadOnly
	    set tcl_div($width) [$f ref]
................................................................................
	BuildCall $b $function $arguments $name
    }

    method cast(BOOLEAN) {value {name ""}} {
	BuildIntCast $b $value [Type "INT BOOLEAN"] $name
    }
    method cast(DOUBLE) {value {name ""}} {
	BuildSIToFP $b [my getInt64 $value] [Type DOUBLE] $name

    }
    method cast(INT) {value {name ""}} {
	# FIXME detect out-of-range values?
	my packInt32 [BuildFPToSI $b $value [Type int] ""] $name
    }
    method cast(int) {value {name ""}} {
	BuildIntCast $b $value [Type int] $name
    }
    method cast(ptr) {value type {name ""}} {
	BuildPointerCast $b $value [Type $type*] $name
    }

    method condBr(INT) {cond true false} {
	set realcond [BuildICmp $b LLVMIntNE [my getInt64 $cond] \
			  [Const 0 int64] ""]

	BuildCondBr $b $realcond [$true ref] [$false ref]
    }
    method condBr {cond true false} {
	BuildCondBr $b $cond [$true ref] [$false ref]
    }

    method constString {content {name "string.constant"}} {

Changes to codegen.compile.tcl.

127
128
129
130
131
132
133
134


135
136
137
138
139
140
141
142
143
144
145
	lassign $desc kind value
	if {$kind ne "literal"} {
	    error "unsubstitutable argument: $desc"
	}
	set type [nameOfType [typeOfLiteral $value]]
	if {$type eq "DOUBLE"} {
	    return [ConstReal [Type $type] $value]
	} elseif {"INT" in $type} {


	    if {$value >= -0x80000000 && $value <= 0x7fffffff} {
		return [$b packInt32 [ConstInt [Type int] $value 0]]
	    } else {
		return [$b packInt64 [ConstInt [Type int64] $value 0]]
	    }
	} else {
	    error "unhandled type for literal \"${value}\": \"$type\""
	}
    }

    method StoreResult {desc value} {







|
>
>
|
|

|







127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
	lassign $desc kind value
	if {$kind ne "literal"} {
	    error "unsubstitutable argument: $desc"
	}
	set type [nameOfType [typeOfLiteral $value]]
	if {$type eq "DOUBLE"} {
	    return [ConstReal [Type $type] $value]
	} elseif {"INT" in $type || $type eq "ENTIER"} {
	    if {$::tcl_platform(wordSize) < 8
		    && $value >= -0x80000000
		    && $value <= 0x7fffffff} {
		return [$b packInt32 [Const $value int]]
	    } else {
		return [$b packInt64 [Const $value int64]]
	    }
	} else {
	    error "unhandled type for literal \"${value}\": \"$type\""
	}
    }

    method StoreResult {desc value} {

Changes to codegen.tcl.

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39









40
41
42
43
44
45
46
..
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
...
163
164
165
166
167
168
169












170
171
172
173
174
175
176
	switch $type {
	    "int" - "INT" {
		return [ConstInt [Type int] $value 0]
	    }
	    "int64" {
		return [ConstInt [Type int64] $value 0]
	    }
	    "INT BOOLEAN" - "boolean" - "bool" {
		if {[string is true -strict $value]} {
		    return [ConstInt [Type int] 1 0]
		}
		if {[string is false -strict $value]} {
		    return [ConstInt [Type int] 0 0]
		}
		error "invalid boolean value \"$value\""
	    }
	    "double" - "DOUBLE" {
		return [ConstReal [Type double] $value]
	    }









	    "STRING" {
		# FIXME: STRING is not an integer type; this is a hack
		puts stderr "WARNING: treating $value as INT despite having STRING type"
		return [ConstInt [Type int] $value 0]
		# TODO is this correct?
		return [ConstString $value [string bytelength $value] 0]
	    }
................................................................................
		return [VoidType]
	    }
	    ^int$ {
		return [Int32Type]
	    }
	    ^STRING$ {
		# FIXME: STRING is not an integer type; this is a hack
		echo "WARNING: Converted STRING to int in type converter"
		return [Int32Type]
		# FIXME: Tcl_Obj is a structure
		return [Type Tcl_Obj*]
	    }
	    ^INT$ - "^INT BOOLEAN$" {
		return [Type named{INT,int,int,int64}]
	    }
	    ^int64$ - ^WIDE$ {
		return [Int64Type]
	    }
	    ^char$ - ^byte$ {
		return [Int8Type]
................................................................................
		return [set v [next {*}$args]]
	    } finally {
		if {[info exists v]} {
		    puts stderr "<<$what<<$v"
		}
	    }
	}












    }

    # Support class definitions
    source [file join [file dirname [info script]] codegen.struct.tcl]
    source [file join [file dirname [info script]] codegen.stack.tcl]
    source [file join [file dirname [info script]] codegen.build.tcl]
    source [file join [file dirname [info script]] codegen.thunk.tcl]







|











>
>
>
>
>
>
>
>
>







 







|




|







 







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







21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
..
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
...
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
	switch $type {
	    "int" - "INT" {
		return [ConstInt [Type int] $value 0]
	    }
	    "int64" {
		return [ConstInt [Type int64] $value 0]
	    }
	    "INT BOOLEAN" - "boolean" {
		if {[string is true -strict $value]} {
		    return [ConstInt [Type int] 1 0]
		}
		if {[string is false -strict $value]} {
		    return [ConstInt [Type int] 0 0]
		}
		error "invalid boolean value \"$value\""
	    }
	    "double" - "DOUBLE" {
		return [ConstReal [Type double] $value]
	    }
	    "bool" {
		if {[string is true -strict $value]} {
		    return [ConstInt [Type bool] 1 0]
		}
		if {[string is false -strict $value]} {
		    return [ConstInt [Type bool] 0 0]
		}
		error "invalid boolean value \"$value\""
	    }
	    "STRING" {
		# FIXME: STRING is not an integer type; this is a hack
		puts stderr "WARNING: treating $value as INT despite having STRING type"
		return [ConstInt [Type int] $value 0]
		# TODO is this correct?
		return [ConstString $value [string bytelength $value] 0]
	    }
................................................................................
		return [VoidType]
	    }
	    ^int$ {
		return [Int32Type]
	    }
	    ^STRING$ {
		# FIXME: STRING is not an integer type; this is a hack
		puts "WARNING: Converted STRING to int in type converter"
		return [Int32Type]
		# FIXME: Tcl_Obj is a structure
		return [Type Tcl_Obj*]
	    }
	    ^INT$ - ^ENTIER$ - "^INT BOOLEAN$" {
		return [Type named{INT,int,int,int64}]
	    }
	    ^int64$ - ^WIDE$ {
		return [Int64Type]
	    }
	    ^char$ - ^byte$ {
		return [Int8Type]
................................................................................
		return [set v [next {*}$args]]
	    } finally {
		if {[info exists v]} {
		    puts stderr "<<$what<<$v"
		}
	    }
	}
	# Binds all current scope variables to their current values.
	# Modification not supported.
	method closure {name arguments body} {
	    set vars [lmap v [uplevel 1 info vars] {
		if {[uplevel 1 [list info exist $v]]} {set v} continue
	    }]
	    oo::objdefine [self] forward $name apply [list \
		[list {*}$vars {*}$arguments] $body \
			[uplevel 1 namespace current]] \
		{*}[lmap v $vars {uplevel 1 [list set $v]}]
	}
	unexport proc
    }

    # Support class definitions
    source [file join [file dirname [info script]] codegen.struct.tcl]
    source [file join [file dirname [info script]] codegen.stack.tcl]
    source [file join [file dirname [info script]] codegen.build.tcl]
    source [file join [file dirname [info script]] codegen.thunk.tcl]

Changes to codegen.thunk.tcl.

60
61
62
63
64
65
66
67



68
69
70
71
72









73
74
75
76

77
78
79
80
81
82
83
84
85
86



87
88
89
90
91









92
93
94
95

96
97
98
99
100
101
102
103
104
105
106
107
108
...
158
159
160
161
162
163
164
165
166
167

168
169
170
171
172
173
174
...
182
183
184
185
186
187
188
189
190
191

192
193
194
195
196
197
198
199
200
201
202

203
204
205
206
207
208
209
...
310
311
312
313
314
315
316
317

318
319
320
321
322









323
324

325
326
327

328

329
330
331
332
333
334
335
...
436
437
438
439
440
441
442

443



444
445
446
447
448
449
450
...
458
459
460
461
462
463
464
465
466


467
468




469
470
471
472
473
474
475
    method API {index name type} {
	upvar 1 stubtable stubtable
	set type [Type func{$type}]
	set ptype [Type $type*]
	set fptr [$b dereference $stubtable 0 2 $index]
	set g [$m variable $name $ptype [ConstPointerNull $ptype]]
	$b store [$b pointerCast $fptr $ptype] $g
	oo::objdefine [self] forward $name apply [list {b c v x args} {



	    if {$v && [llength $args] < $c} {
		return -code error "insufficient arguments"
	    } elseif {!$v && [llength $args] != $c} {
		return -code error "wrong number of arguments"
	    }









	    set call [$b call [$b load $x] $args]
	    SetTailCall $call 0
	    return $call
	} [namespace current]] $b [CountParamTypes $type] [IsFunctionVarArg $type] [GetNamedGlobal [$m ref] $name]

    }

    method IntAPI {index name type} {
	upvar 1 intstubtable stubtable
	set type [Type func{$type}]
	set ptype [Type $type*]
	set fptr [$b dereference $stubtable 0 2 $index]
	set g [$m variable $name $ptype [ConstPointerNull $ptype]]
	$b store [$b pointerCast $fptr $ptype] $g
	oo::objdefine [self] forward $name apply [list {b c v x args} {



	    if {$v && [llength $args] < $c} {
		return -code error "insufficient arguments"
	    } elseif {!$v && [llength $args] != $c} {
		return -code error "wrong number of arguments"
	    }









	    set call [$b call [$b load $x] $args]
	    SetTailCall $call 0
	    return $call
	} [namespace current]] $b [CountParamTypes $type] [IsFunctionVarArg $type] [GetNamedGlobal [$m ref] $name]

    }

    method APIVar {name type init} {
	set g [$m variable $name $type [ConstPointerNull $type]]
	$b store $init $g
	oo::objdefine [self] forward $name apply {{b g} {$b load $g}} $b $g
	oo::objdefine [self] unexport $name
    }

    method InitTclAPI {interp} {
	set stubtable [$b dereference $interp 0 3]
	set intstubtable [$b dereference [$b dereference $stubtable 0 1] 0 1]
	# Define the Tcl API functions we're using
................................................................................
	$fn attribute AlwaysInline
	[$fn block] build $b {
	    set refCount [$b getelementptr [$fn param 0 "objPtr"] \
		    [list $0 $0] "refCount"]
	    $b store [$b add [$b load $refCount] $1] $refCount
	    $b ret
	}
	oo::objdefine [self] forward Tcl_IncrRefCount apply {{b fn objPtr} {
	    $b call [$fn ref] [list $objPtr]
	}} $b $fn


	set fn [$m function.create Tcl_DecrRefCount [Type func{void<-$Tcl_Obj}]]
	$fn private
	$fn attribute AlwaysInline
	set enterblock [$fn block]
	set freeblock [$fn block "freeObject"]
	set nextblock [$fn block "leave"]
................................................................................
	$freeblock build $b {
	    my TclFreeObj $objPtr
	    $b ret
	}
	$nextblock build $b {
	    $b ret
	}
	oo::objdefine [self] forward Tcl_DecrRefCount apply {{b fn objPtr} {
	    $b call [$fn ref] [list $objPtr]
	}} $b $fn


	set fn [$m function.create writeline [Type func{void<-char*}]]
	$fn private
	$fn attribute NoInline
	[$fn block] build $b {
	    my printf [$b constString "%s\n"] [$fn param 0]
	    $b ret
	}
	interp alias {} ::LLVM::writeline {} apply [list {b fn s} {
	    $b call [$fn ref] [list [$b constString $s]]
	} [namespace current]] $b $fn


	$cur build-in $b
    }

    method MathFunc {name type body} {
	upvar 1 funs funs func func
	if {$name in $funs} return
................................................................................
	set n $name
	if {$n eq "stdout"} {set n __stdoutp}
	if {$n eq "stderr"} {set n __stderrp}
	if {[GetTypeKind $type] eq "LLVMFunctionTypeKind"} {
	    set g [$m function.extern $n $type]
	    set c [CountParamTypes $type]
	    set v [IsFunctionVarArg $type]
	    oo::objdefine [self] forward $name apply {{b c v x args} {

		if {$v && [llength $args] < $c} {
		    return -code error "insufficient arguments"
		} elseif {!$v && [llength $args] != $c} {
		    return -code error "wrong number of arguments"
		}









		$b call $x $args
	    }} $b $c $v $g

	} else {
	    set g [$m global.get $n $type]
	    oo::objdefine [self] forward $name \

		apply {{b x} {$b load $x}} $b $g

	}
	return $g
    }

    method thunk {name bytecode} {
	set func [$m function.get $name]
	set thunk [$m function.create cmd.thunk$name $Tcl_ObjCmdType]
................................................................................
	# Ready things for the next thing in the main instruction stream
	$newblock build-in $b
    }

    method MapDefaultToArgument {argType argDefault argSlot} {
	switch $argType {
	    "INT" {

		return [$b packInt32 [Const $argDefault $argType]]



	    }
	    default {
		return [Const $argDefault $argType]
	    }
	}
    }

................................................................................
		    set value [$b packInt32 [$b load $argSlot]]
		}
	    }
	    INT - STRING {# FIXME interim fix; no GetNumberFromObj...
		try {
		    return [my Tcl_GetWideIntFromObj $interp $argObj $argSlot]
		} finally {
		    set value [$b select \
			[$b eq [$b dereference $argObj 0 3] [my tclIntType]] \


			[$b packInt32 [$b load [$b cast(ptr) [$b gep $argObj 0 4] int]]] \
			[$b packInt64 [$b load $argSlot]]]




		}
	    }
	    DOUBLE {
		try {
		    return [my Tcl_GetDoubleFromObj $interp $argObj $argSlot]
		} finally {
		    set value [$b load $argSlot]







|
>
>
>





>
>
>
>
>
>
>
>
>
|


<
>









|
>
>
>





>
>
>
>
>
>
>
>
>
|


<
>





|







 







|

<
>







 







|

<
>








|

<
>







 







|
>





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


<
>
|
>







 







>
|
>
>
>







 







|
|
>
>
|
|
>
>
>
>







60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87

88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118

119
120
121
122
123
124
125
126
127
128
129
130
131
132
...
182
183
184
185
186
187
188
189
190

191
192
193
194
195
196
197
198
...
206
207
208
209
210
211
212
213
214

215
216
217
218
219
220
221
222
223
224
225

226
227
228
229
230
231
232
233
...
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357

358
359
360

361
362
363
364
365
366
367
368
369
370
...
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
...
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
    method API {index name type} {
	upvar 1 stubtable stubtable
	set type [Type func{$type}]
	set ptype [Type $type*]
	set fptr [$b dereference $stubtable 0 2 $index]
	set g [$m variable $name $ptype [ConstPointerNull $ptype]]
	$b store [$b pointerCast $fptr $ptype] $g
	set c [CountParamTypes $type]
	set v [IsFunctionVarArg $type]
	my closure $name args {
	    # Because these are *much* less nasty than crashes!
	    if {$v && [llength $args] < $c} {
		return -code error "insufficient arguments"
	    } elseif {!$v && [llength $args] != $c} {
		return -code error "wrong number of arguments"
	    }
	    foreach expected [GetParamTypes $type] got $args {
		if {[incr i]>$c} break;	# Stop checking; varargs...
		set got [TypeOf $got]
		if {$got ne $expected} {
		    return -code error "type mismatch at argument ${i}:\
			    expected [PrintTypeToString $expected] but\
			    got [PrintTypeToString $got]"
		}
	    }
	    set call [$b call [$b load $g] $args]
	    SetTailCall $call 0
	    return $call

	}
    }

    method IntAPI {index name type} {
	upvar 1 intstubtable stubtable
	set type [Type func{$type}]
	set ptype [Type $type*]
	set fptr [$b dereference $stubtable 0 2 $index]
	set g [$m variable $name $ptype [ConstPointerNull $ptype]]
	$b store [$b pointerCast $fptr $ptype] $g
	set c [CountParamTypes $type]
	set v [IsFunctionVarArg $type]
	my closure $name args {
	    # Because these are *much* less nasty than crashes!
	    if {$v && [llength $args] < $c} {
		return -code error "insufficient arguments"
	    } elseif {!$v && [llength $args] != $c} {
		return -code error "wrong number of arguments"
	    }
	    foreach expected [GetParamTypes $type] got $args {
		if {[incr i]>$c} break; # Stop checking; varargs...
		set got [TypeOf $got]
		if {$got ne $expected} {
		    return -code error "type mismatch at argument ${i}:\
			    expected [PrintTypeToString $expected] but\
			    got [PrintTypeToString $got]"
		}
	    }
	    set call [$b call [$b load $g] $args]
	    SetTailCall $call 0
	    return $call

	}
    }

    method APIVar {name type init} {
	set g [$m variable $name $type [ConstPointerNull $type]]
	$b store $init $g
	my closure $name {} {$b load $g}
	oo::objdefine [self] unexport $name
    }

    method InitTclAPI {interp} {
	set stubtable [$b dereference $interp 0 3]
	set intstubtable [$b dereference [$b dereference $stubtable 0 1] 0 1]
	# Define the Tcl API functions we're using
................................................................................
	$fn attribute AlwaysInline
	[$fn block] build $b {
	    set refCount [$b getelementptr [$fn param 0 "objPtr"] \
		    [list $0 $0] "refCount"]
	    $b store [$b add [$b load $refCount] $1] $refCount
	    $b ret
	}
	my closure Tcl_IncrRefCount objPtr {
	    $b call [$fn ref] [list $objPtr]

	}

	set fn [$m function.create Tcl_DecrRefCount [Type func{void<-$Tcl_Obj}]]
	$fn private
	$fn attribute AlwaysInline
	set enterblock [$fn block]
	set freeblock [$fn block "freeObject"]
	set nextblock [$fn block "leave"]
................................................................................
	$freeblock build $b {
	    my TclFreeObj $objPtr
	    $b ret
	}
	$nextblock build $b {
	    $b ret
	}
	my closure Tcl_DecrRefCount objPtr {
	    $b call [$fn ref] [list $objPtr]

	}

	set fn [$m function.create writeline [Type func{void<-char*}]]
	$fn private
	$fn attribute NoInline
	[$fn block] build $b {
	    my printf [$b constString "%s\n"] [$fn param 0]
	    $b ret
	}
	my closure writeline s {
	    $b call [$fn ref] [list [$b constString $s]]

	}

	$cur build-in $b
    }

    method MathFunc {name type body} {
	upvar 1 funs funs func func
	if {$name in $funs} return
................................................................................
	set n $name
	if {$n eq "stdout"} {set n __stdoutp}
	if {$n eq "stderr"} {set n __stderrp}
	if {[GetTypeKind $type] eq "LLVMFunctionTypeKind"} {
	    set g [$m function.extern $n $type]
	    set c [CountParamTypes $type]
	    set v [IsFunctionVarArg $type]
	    my closure $name args {
		# Because these are *much* less nasty than crashes!
		if {$v && [llength $args] < $c} {
		    return -code error "insufficient arguments"
		} elseif {!$v && [llength $args] != $c} {
		    return -code error "wrong number of arguments"
		}
		for {set i 0} {$i < $c} {incr i} {
		    set expected [TypeOf [GetParam $g $i]]
		    set got [TypeOf [lindex $args $i]]
		    if {$got ne $expected} {
			return -code error "type mismatch at argument ${i}:\
				expected [PrintTypeToString $expected] but\
				got [PrintTypeToString $got]"
		    }
		}
		$b call $g $args

	    }
	} else {
	    set g [$m global.get $n $type]

	    my closure $name {} {
		$b load $g
	    }
	}
	return $g
    }

    method thunk {name bytecode} {
	set func [$m function.get $name]
	set thunk [$m function.create cmd.thunk$name $Tcl_ObjCmdType]
................................................................................
	# Ready things for the next thing in the main instruction stream
	$newblock build-in $b
    }

    method MapDefaultToArgument {argType argDefault argSlot} {
	switch $argType {
	    "INT" {
		if {$::tcl_platform(wordSize) < 8} {
		    return [$b packInt32 [Const $argDefault $argType]]
		} else {
		    return [$b packInt64 [Const $argDefault int64]]
		}
	    }
	    default {
		return [Const $argDefault $argType]
	    }
	}
    }

................................................................................
		    set value [$b packInt32 [$b load $argSlot]]
		}
	    }
	    INT - STRING {# FIXME interim fix; no GetNumberFromObj...
		try {
		    return [my Tcl_GetWideIntFromObj $interp $argObj $argSlot]
		} finally {
		    if {$::tcl_platform(wordSize) == 4} {
			set bit1 [$b eq [$b dereference $argObj 0 3] \
				[my tclIntType]]
			set bit2 [$b packInt32 [$b load \
				[$b cast(ptr) [$b gep $argObj 0 4] int]]]
			set bit3 [$b packInt64 [$b load $argSlot]]
			set value [$b select $bit1 $bit2 $bit3]
		    } else {	# sizeof(long) = 8
			set value [$b packInt64 [$b load $argSlot]]
		    }
		}
	    }
	    DOUBLE {
		try {
		    return [my Tcl_GetDoubleFromObj $interp $argObj $argSlot]
		} finally {
		    set value [$b load $argSlot]

Changes to demo.tcl.

32
33
34
35
36
37
38

39
40




41
42
43
44
45
46
47
..
72
73
74
75
76
77
78









79
80
81
82
83
84
85
...
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
	set a $b
	set b $c
    }
    return $b
}
proc inttest {x} {
    set x [expr {int($x)}]

    expr {($x / 3) * 2 + $x}
}




proc tantest {x} {
    return [expr {tan(double($x))}]
}
proc polartest {u v} {
    set th [expr {atan2($v,$u)}]
    set r [expr {hypot($v,$u)}]
    set u2 [expr {$r * cos($th)}]
................................................................................
    set xx [expr {$xx + 1}]
    set ser [expr {$ser + $cof / $xx}]
    set cof -5.36382e-6
    set xx [expr {$xx + 1}]
    set ser [expr {$ser + $cof / $xx}]
    return [expr {$tmp + log(2.50662827465 * $ser)}]
}









#
#########################################################################

if 1 {
    set name cos
    # set name fib
} else {
................................................................................
puts "Type signature: ${name}([join $argumentTypes ","]):$returnType"
# puts [join [lmap {a b} $bytecode {string cat $a ": " $b}] \n]

dict set bytecode quads $quads
dict set bytecode vtypes $vtypes
}

set demos {{fib 85} {cos 1.2} {expr {cos(1.2)}} {tantest 1.2} {inttest 345} {math::ln_Gamma 1.3} {polartest 0.6 0.8}}
foreach op $demos {puts "${op}: [eval $op] ([time $op 12345])"}
try {
    LLVM optimise fib cos tantest inttest math::ln_Gamma
    puts ========================POST========================
    puts [LLVM post]
    puts ========================POST========================
} on error {msg opt} {
    puts [dict get $opt -errorinfo]
    puts ========================PRE========================
    puts [LLVM pre]
    exit
}
foreach op $demos {puts "${op}: [eval $op] ([time $op 1234567])"}







>


>
>
>
>







 







>
>
>
>
>
>
>
>
>







 







|


|










32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
..
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
...
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
	set a $b
	set b $c
    }
    return $b
}
proc inttest {x} {
    set x [expr {int($x)}]
    incr x $x
    expr {($x / 3) * 2 + $x}
}
proc shift {x y} {
    set y [expr {int($y)}]
    expr {int($x) >> $y}
}
proc tantest {x} {
    return [expr {tan(double($x))}]
}
proc polartest {u v} {
    set th [expr {atan2($v,$u)}]
    set r [expr {hypot($v,$u)}]
    set u2 [expr {$r * cos($th)}]
................................................................................
    set xx [expr {$xx + 1}]
    set ser [expr {$ser + $cof / $xx}]
    set cof -5.36382e-6
    set xx [expr {$xx + 1}]
    set ser [expr {$ser + $cof / $xx}]
    return [expr {$tmp + log(2.50662827465 * $ser)}]
}

proc powmul {n r} {
    set n [expr {int($n)}]
    set r [expr {int($r)}]
    for {set i 0} {$i < $n} {incr i} {
	set r [expr {$r * $n}]
    }
    return $r
}
#
#########################################################################

if 1 {
    set name cos
    # set name fib
} else {
................................................................................
puts "Type signature: ${name}([join $argumentTypes ","]):$returnType"
# puts [join [lmap {a b} $bytecode {string cat $a ": " $b}] \n]

dict set bytecode quads $quads
dict set bytecode vtypes $vtypes
}

set demos {{fib 85} {cos 1.2} {expr {cos(1.2)}} {tantest 1.2} {inttest 345} {math::ln_Gamma 1.3} {polartest 0.6 0.8} {powmul 13 3}}
foreach op $demos {puts "${op}: [eval $op] ([time $op 12345])"}
try {
    LLVM optimise fib cos tantest inttest math::ln_Gamma shift powmul
    puts ========================POST========================
    puts [LLVM post]
    puts ========================POST========================
} on error {msg opt} {
    puts [dict get $opt -errorinfo]
    puts ========================PRE========================
    puts [LLVM pre]
    exit
}
foreach op $demos {puts "${op}: [eval $op] ([time $op 1234567])"}

Changes to quadcode.tcl.

11
12
13
14
15
16
17

18
19
20
21
22
23
24
...
140
141
142
143
144
145
146


147
148
149
150
151
152
153
...
166
167
168
169
170
171
172

173
174
175
176
177
178
179
...
217
218
219
220
221
222
223

224
225
226
227
228
229
230
231
232
233
234

235

236
237
238
239
240
241
242
...
250
251
252
253
254
255
256


257
258
259
260
261
262
263
...
281
282
283
284
285
286
287












288
289
290
291
292
293
294
...
751
752
753
754
755
756
757


758
759
760
761
762
763
764
....
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
....
1929
1930
1931
1932
1933
1934
1935





1936
1937
1938
1939
1940
1941
1942
....
2294
2295
2296
2297
2298
2299
2300

2301
2302
2303
2304
2305
2306
2307
#------------------------------------------------------------------------------

package require tclbdd::datalog

namespace eval :: {
    variable verbose
    variable logtime

    if {![info exist verbose]} {
	set verbose 0
    }
    if {![info exist logtime]} {
	set logtime 1
    }

................................................................................
	    le -
	    listIndexImm -
	    lt -
	    mod -
	    mult -
	    ne -
	    pop -


	    sub {
		incr depth -1
	    }
	    incrScalar1Imm -
	    loadScalar1 -
	    dup -
	    push1 {
................................................................................
	    }
	    foreach_end {
		puts "foreach_end"
	    }
	    foreach_step {
		puts "foreach_step"
	    }

	    infoLevelArgs -
	    nop -
	    startCommand -
	    storeScalar1 -
	    listLength -
	    tryCvtToNumeric -
	    uminus {
................................................................................
#		      tcl::unsupported::getbytecode
#
# Results:
#	Returns a list of three-address instructions.

proc bytecode-to-quads {bytecodeVar} {
    upvar 1 $bytecodeVar bytecode


    set quads {};		# List of instructions under construction
    set fixup {};		# Dictionary whose keys are jump targets
    ;				# and the values are lists of quad program 
    ;				# counters that jump to them, used to fix up
    ;				# forward jumps.
    set tempStack {}

    # Iterate the instruction list
    dict for {pc insn} [dict get $bytecode instructions] {
	if {![dict exists $bytecode stackState $pc]} {

	    puts "warning: unreachable: $pc: $insn"

	    continue
	}
	lassign [dict get $bytecode stackState $pc] state depth

	# Fix up any quads that jump to the current quad
	dict set quadindex $pc [llength $quads]
	if {[dict exists $fixup $pc]} {
................................................................................
	    add -
	    div -
	    eq -
	    gt -
	    le -
	    lt -
	    mod -


	    mult -
	    ne -
	    sub {		# Binary ops
		set v1 [lindex $tempStack [incr depth -1]]
		set v0 [lindex $tempStack [incr depth -1]]
		set r [list temp $pc]
		lappend quads [list [lindex $insn 0] $r $v0 $v1]
................................................................................
		set var [list var $varName]
		set result [list temp $pc]
		lset! tempStack $depth $result
		lappend quads \
		    [list add $var $var [list literal $delta]] \
		    [list copy $result $var]
	    }












	    invokeReplace {
		set acount [lindex $insn 1]
		set rcount [lindex $insn 2]
		set depth [expr {$depth - $acount - 1}]
		set result [list temp $pc]
		set qd [list invokeReplace \
			    $result \
................................................................................
		}
	    }
	}
	switch -exact -- [lindex $insn 0] {
	    add -
	    div -
	    mod -


	    mult -
	    sub {
		# FIXME - Need to decide how to handle int overflow
		loadSeq $i [expr {$i + 1}]
		loadIsBinaryArith $i
		loadNoSideEffect $i
	    }
................................................................................
# Results:
#	Returns the deduced data type of q's left hand side

proc typeOfResult {varTypes q} {
    switch -exact -- [lindex $q 0] {
	add -
	div -
	mod -
	mult -
	sub {
	    set t1 [typeOfOperand $varTypes [lindex $q 2]]
	    set t2 [typeOfOperand $varTypes [lindex $q 3]]
	    if {($t1 & $dataType::DOUBLE) == $dataType::DOUBLE
		|| ($t2 & $dataType::DOUBLE) == $dataType::DOUBLE} {
		return $dataType::DOUBLE
................................................................................
	    } elseif {($t1 & $dataType::ENTIER) == $dataType::ENTIER
		       && ($t2 & $dataType::ENTIER) == $dataType::ENTIER} {
		return $dataType::ENTIER
	    } else {
		return $dataType::NUMERIC
	    }
	}





	copy {
	    return [typeOfOperand $varTypes [lindex $q 2]]
	}
	eq -
	ge -
	gt -
	le -
................................................................................
    package require math
    auto_load ::math::ln_Gamma
    set procname math::ln_Gamma
}
set bytecode [::tcl::unsupported::getbytecode proc $procname]

set verbose 0


bytecode-length bytecode
bytecode-stack-state bytecode
set quads [bytecode-to-quads bytecode]

if {$verbose} {
    puts "As translated by bytecode-to-quads"







>







 







>
>







 







>







 







>











>
|
>







 







>
>







 







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







 







>
>







 







<







 







>
>
>
>
>







 







>







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
...
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
...
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
...
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
...
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
...
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
....
1934
1935
1936
1937
1938
1939
1940

1941
1942
1943
1944
1945
1946
1947
....
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
....
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
#------------------------------------------------------------------------------

package require tclbdd::datalog

namespace eval :: {
    variable verbose
    variable logtime
    variable unreachablewarning 0
    if {![info exist verbose]} {
	set verbose 0
    }
    if {![info exist logtime]} {
	set logtime 1
    }

................................................................................
	    le -
	    listIndexImm -
	    lt -
	    mod -
	    mult -
	    ne -
	    pop -
	    lshift -
	    rshift -
	    sub {
		incr depth -1
	    }
	    incrScalar1Imm -
	    loadScalar1 -
	    dup -
	    push1 {
................................................................................
	    }
	    foreach_end {
		puts "foreach_end"
	    }
	    foreach_step {
		puts "foreach_step"
	    }
	    incrScalar1 -
	    infoLevelArgs -
	    nop -
	    startCommand -
	    storeScalar1 -
	    listLength -
	    tryCvtToNumeric -
	    uminus {
................................................................................
#		      tcl::unsupported::getbytecode
#
# Results:
#	Returns a list of three-address instructions.

proc bytecode-to-quads {bytecodeVar} {
    upvar 1 $bytecodeVar bytecode
    variable unreachablewarning

    set quads {};		# List of instructions under construction
    set fixup {};		# Dictionary whose keys are jump targets
    ;				# and the values are lists of quad program 
    ;				# counters that jump to them, used to fix up
    ;				# forward jumps.
    set tempStack {}

    # Iterate the instruction list
    dict for {pc insn} [dict get $bytecode instructions] {
	if {![dict exists $bytecode stackState $pc]} {
	    if {$unreachablewarning} {
		puts "warning: unreachable: $pc: $insn"
	    }
	    continue
	}
	lassign [dict get $bytecode stackState $pc] state depth

	# Fix up any quads that jump to the current quad
	dict set quadindex $pc [llength $quads]
	if {[dict exists $fixup $pc]} {
................................................................................
	    add -
	    div -
	    eq -
	    gt -
	    le -
	    lt -
	    mod -
	    lshift -
	    rshift -
	    mult -
	    ne -
	    sub {		# Binary ops
		set v1 [lindex $tempStack [incr depth -1]]
		set v0 [lindex $tempStack [incr depth -1]]
		set r [list temp $pc]
		lappend quads [list [lindex $insn 0] $r $v0 $v1]
................................................................................
		set var [list var $varName]
		set result [list temp $pc]
		lset! tempStack $depth $result
		lappend quads \
		    [list add $var $var [list literal $delta]] \
		    [list copy $result $var]
	    }
	    incrScalar1 {
		set varNum [string range [lindex $insn 1] 1 end]
		set varDesc [lindex [dict get $bytecode variables] $varNum]
		set varName [lindex $varDesc 1]
		set val [lindex $tempStack [incr depth -1]]
		set var [list var $varName]
		set result [list temp $pc]
		lset! tempStack $depth $result
		lappend quads \
		    [list add $var $var $val] \
		    [list copy $result $var]
	    }
	    invokeReplace {
		set acount [lindex $insn 1]
		set rcount [lindex $insn 2]
		set depth [expr {$depth - $acount - 1}]
		set result [list temp $pc]
		set qd [list invokeReplace \
			    $result \
................................................................................
		}
	    }
	}
	switch -exact -- [lindex $insn 0] {
	    add -
	    div -
	    mod -
	    lshift -
	    rshift -
	    mult -
	    sub {
		# FIXME - Need to decide how to handle int overflow
		loadSeq $i [expr {$i + 1}]
		loadIsBinaryArith $i
		loadNoSideEffect $i
	    }
................................................................................
# Results:
#	Returns the deduced data type of q's left hand side

proc typeOfResult {varTypes q} {
    switch -exact -- [lindex $q 0] {
	add -
	div -

	mult -
	sub {
	    set t1 [typeOfOperand $varTypes [lindex $q 2]]
	    set t2 [typeOfOperand $varTypes [lindex $q 3]]
	    if {($t1 & $dataType::DOUBLE) == $dataType::DOUBLE
		|| ($t2 & $dataType::DOUBLE) == $dataType::DOUBLE} {
		return $dataType::DOUBLE
................................................................................
	    } elseif {($t1 & $dataType::ENTIER) == $dataType::ENTIER
		       && ($t2 & $dataType::ENTIER) == $dataType::ENTIER} {
		return $dataType::ENTIER
	    } else {
		return $dataType::NUMERIC
	    }
	}
	mod -
	lshift -
	rshift {
	    return $dataType::INT
	}
	copy {
	    return [typeOfOperand $varTypes [lindex $q 2]]
	}
	eq -
	ge -
	gt -
	le -
................................................................................
    package require math
    auto_load ::math::ln_Gamma
    set procname math::ln_Gamma
}
set bytecode [::tcl::unsupported::getbytecode proc $procname]

set verbose 0
set unreachablewarning 1

bytecode-length bytecode
bytecode-stack-state bytecode
set quads [bytecode-to-quads bytecode]

if {$verbose} {
    puts "As translated by bytecode-to-quads"