tclquadcode

Check-in [a8a6795c88]
Login

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

Overview
Comment:Implementation of [info level].
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256:a8a6795c88d0375202c3c05bd5e24fa72fe1a649dcb256ba015ace4473667783
User & Date: dkf 2017-10-31 15:36:33
Context
2017-11-01
10:52
Hide generated functions. Stop problems with ENTIER in codegen; INT is 64-bit. check-in: 97f690371a user: dkf tags: trunk
2017-10-31
15:36
Implementation of [info level]. check-in: a8a6795c88 user: dkf tags: trunk
15:36
Added documentation. Closed-Leaf check-in: bcbfa13992 user: dkf tags: minor change, info-level
2017-10-30
18:22
Added metadata for docker check-in: 723181c542 user: rkeene tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to codegen/build.tcl.

299
300
301
302
303
304
305




































306
307
308
309
310
311
312
    #
    # Results:
    #	An LLVM value reference.

    method frame.value {callframetuple {name ""}} {
	my extract $callframetuple 1 $name
    }





































    # Builder:frame.create --
    #
    #	Create and initialise a callframe.
    #
    # Parameters:
    #	varlist -







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







299
300
301
302
303
304
305
306
307
308
309
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
336
337
338
339
340
341
342
343
344
345
346
347
348
    #
    # Results:
    #	An LLVM value reference.

    method frame.value {callframetuple {name ""}} {
	my extract $callframetuple 1 $name
    }

    # Builder:frame.args(INT) --
    #
    #	Extract the list of arguments from a callframe. Part of [info level].
    #
    # Parameters:
    #	depth -	An INT saying which frame to get the arguments from, with the
    #		value interpretation as used in [info frame].
    #	callframetuple -
    #		The CALLFRAME-tuple LLVM value reference.
    #	name (optional) -
    #		A name to give to the result value.
    #
    # Results:
    #	An LLVM FAIL STRING reference.

    method frame.args(INT) {depth callframe {name ""}} {
	my call ${tcl.callframe.getarglist} [list $callframe $depth] $name
    }

    # Builder:frame.depth --
    #
    #	Extract the call depth from a callframe. Part of [info level].
    #
    # Parameters:
    #	callframetuple -
    #		The CALLFRAME-tuple LLVM value reference.
    #	name (optional) -
    #		A name to give to the result value.
    #
    # Results:
    #	An LLVM INT reference.

    method frame.depth {callframe {name ""}} {
	my call ${tcl.callframe.depth} [list $callframe] $name
    }

    # Builder:frame.create --
    #
    #	Create and initialise a callframe.
    #
    # Parameters:
    #	varlist -

Changes to codegen/compile.tcl.

777
778
779
780
781
782
783















784
785
786
787
788
789
790
		    foreach aa $arguments {
			set arguments [lassign $arguments a]
			if {$a ni $arguments && consumed($a, $pc + 1)} {
			    lappend consumed $a
			}
		    }
		}















		"strcat" {
		    set srcs [lassign $l opcode tgt src1]
		    set name [my LocalVarName $tgt]
		    set type [my OperandType $src1]
		    set val [my LoadOrLiteral $src1]
		    if {!refType($type)} {
			set result [$b stringify($type) $val $name]







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







777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
		    foreach aa $arguments {
			set arguments [lassign $arguments a]
			if {$a ni $arguments && consumed($a, $pc + 1)} {
			    lappend consumed $a
			}
		    }
		}
		"frameArgs" {
		    lassign $l opcode tgt src
		    set name [my LocalVarName $tgt]
		    set opcode frame.args
		    append opcode ( [my ValueTypes $src] )
		    set val [my LoadOrLiteral $src]
		    set result [$b $opcode $val $theframe $name]
		    my StoreResult $tgt $result
		}
		"frameDepth" {
		    lassign $l opcode tgt
		    set name [my LocalVarName $tgt]
		    set result [$b frame.depth $theframe $name]
		    my StoreResult $tgt $result
		}
		"strcat" {
		    set srcs [lassign $l opcode tgt src1]
		    set name [my LocalVarName $tgt]
		    set type [my OperandType $src1]
		    set val [my LoadOrLiteral $src1]
		    if {!refType($type)} {
			set result [$b stringify($type) $val $name]

Changes to codegen/jit.tcl.

280
281
282
283
284
285
286




287
288
289
290
291
292
293
...
450
451
452
453
454
455
456




457
458
459
460
461
462
463
...
473
474
475
476
477
478
479






480
481
482
483
484
485
486
		    lappend publicInterface $c
		}
	    }

	    # Now we generate declarations for the functions we'll build
	    foreach c $compiledProcs {
		$c generateDeclaration $module




	    }

	    # Spit the code out
	    foreach c $compiledProcs {
		$c compile
	    }

................................................................................
		    lappend publicInterface $c
		}
	    }

	    # Now we generate declarations for the functions we'll build
	    foreach c $compiledProcs {
		$c generateDeclaration $module




	    }

	    # Spit the code out
	    foreach c $compiledProcs {
		$c compile
	    }

................................................................................
	    $module verify

	    # Do the optimization itself
	    $module optimize $optimiseLevel

	    # Apply garbage collection
	    $module gcfuncs







	    # Convert to DLL
	    close [file tempfile outfile $name.o]
	    try {
		$module writeobject $outfile
		Link $outfile $filename
	    } finally {







>
>
>
>







 







>
>
>
>







 







>
>
>
>
>
>







280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
...
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
...
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
		    lappend publicInterface $c
		}
	    }

	    # Now we generate declarations for the functions we'll build
	    foreach c $compiledProcs {
		$c generateDeclaration $module

		if {$debug} {
		    $c printTypedQuads stdout
		}
	    }

	    # Spit the code out
	    foreach c $compiledProcs {
		$c compile
	    }

................................................................................
		    lappend publicInterface $c
		}
	    }

	    # Now we generate declarations for the functions we'll build
	    foreach c $compiledProcs {
		$c generateDeclaration $module

		if {$debug} {
		    $c printTypedQuads stdout
		}
	    }

	    # Spit the code out
	    foreach c $compiledProcs {
		$c compile
	    }

................................................................................
	    $module verify

	    # Do the optimization itself
	    $module optimize $optimiseLevel

	    # Apply garbage collection
	    $module gcfuncs

	    # In debug mode, print the LLVM IR at this point
	    if {$debug} {
		puts "===DUMPING MODULE IR==="
		puts [$module dump]
	    }

	    # Convert to DLL
	    close [file tempfile outfile $name.o]
	    try {
		$module writeobject $outfile
		Link $outfile $filename
	    } finally {

Changes to codegen/varframe.tcl.

19
20
21
22
23
24
25

26
27
28
29
30
31
32
...
120
121
122
123
124
125
126






































































127
128
129
130
131
132
133
oo::define Builder {
    # Variables holding implementations of Tcl's callframe handling
    variable tcl.callframe.init tcl.callframe.makevar tcl.callframe.clear
    variable tcl.callframe.store.string tcl.callframe.store.numeric
    variable tcl.callframe.load tcl.callframe.bindvar
    variable tcl.callframe.lookup.varns tcl.callframe.lookup.var
    variable tcl.callframe.lookup.upvar


    # Helper functions
    variable var.hash.getValue var.setNamespaceVar var.clearNamespaceVar
    variable tcl.read.var.ptr tcl.write.var.ptr tcl.unset.var.ptr
    variable tcl.write.var.ptr.numeric
    variable var.isTraced var.defined var.isLink var.link var.isInHash
    variable var.hash.refCount var.flag.set var.link.set var.hash.getKey
................................................................................
	    set rcPtr [my gep $proc 0 Proc.refCount]
	    my store [my sub [my load $rcPtr] $1] $rcPtr
	    # TODO: ought to theoretically delete the Proc when it has a
	    # refcount of 0. But we can actually postpone that until the
	    # library is deleted. And we don't do that anyway...
	    my ret
	}







































































	##### var.followLinks #####
	#
	# Type signature: var:Var* -> Var*
	#
	# Given a particular variable, follow its chain of links (which might
	# be none at all) to get to the actual variable holding the real







>







 







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







19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
...
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
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
198
199
200
201
202
203
204
oo::define Builder {
    # Variables holding implementations of Tcl's callframe handling
    variable tcl.callframe.init tcl.callframe.makevar tcl.callframe.clear
    variable tcl.callframe.store.string tcl.callframe.store.numeric
    variable tcl.callframe.load tcl.callframe.bindvar
    variable tcl.callframe.lookup.varns tcl.callframe.lookup.var
    variable tcl.callframe.lookup.upvar
    variable tcl.callframe.getarglist tcl.callframe.depth

    # Helper functions
    variable var.hash.getValue var.setNamespaceVar var.clearNamespaceVar
    variable tcl.read.var.ptr tcl.write.var.ptr tcl.unset.var.ptr
    variable tcl.write.var.ptr.numeric
    variable var.isTraced var.defined var.isLink var.link var.isInHash
    variable var.hash.refCount var.flag.set var.link.set var.hash.getKey
................................................................................
	    set rcPtr [my gep $proc 0 Proc.refCount]
	    my store [my sub [my load $rcPtr] $1] $rcPtr
	    # TODO: ought to theoretically delete the Proc when it has a
	    # refcount of 0. But we can actually postpone that until the
	    # library is deleted. And we don't do that anyway...
	    my ret
	}

	##### tcl.callframe.getarglist #####
	#
	# Type signature: frame:CALLFRAME * depth:INT -> STRING?
	#
	# Get the list of arguments to a callframe (depth says which frame,
	# given the curren context frame).

	set f [$m local "tcl.callframe.getarglist" STRING?<-CALLFRAME,INT]
	params frame level
	build {
	    nonnull $frame
	    set interp [$api tclInterp]
	    set level0 [my cast(int) [my getInt64 $level] "level"]
	    set f0 $frame
	    my condBr [my eq $level0 $0] $found $search
	label search:
	    set lPtr [my alloc int]
	    set fPtr [my alloc CALLFRAME]
	    my store $level0 $lPtr
	    my store $frame $fPtr
	    set root [my dereference $interp 0 Interp.rootFramePtr]
	    my condBr [my lt $level0 $0] $applyOffset $findFrame
	label applyOffset:
	    set l2 [my add $level0 [my dereference $frame 0 CallFrame.level]]
	    my store $l2 $lPtr
	    my br $findFrame
	label findFrame:
	    set level [my load $lPtr]
	    set frame [my load $fPtr]
	    my condBr [my and \
			   [my neq [my dereference $frame 0 CallFrame.level] $level] \
			   [my neq $frame $root]] \
		$nextFrame $checkFound
	label nextFrame:
	    my store [my dereference $frame 0 CallFrame.callerVarPtr] $fPtr
	    my br $findFrame
	label checkFound:
	    my condBr [my eq $frame $root] $failed $found
	label found:
	    set frame [my phi [list $f0 $frame] [list $entry $checkFound] "frame"]
	    set args [$api Tcl_NewListObj \
			  [my dereference $frame 0 CallFrame.objc] \
			  [my dereference $frame 0 CallFrame.objv]]
	    my addReference(STRING) $args
	    my ret [my ok $args]
	label failed:
	    set levelobj [$api Tcl_NewIntObj $level0]
	    set levelstr [$api Tcl_GetString $levelobj]
	    $api Tcl_SetObjResult $interp [$api \
		Tcl_ObjPrintf [my constString "bad level \"%s\""] $levelstr]
	    $api Tcl_SetErrorCode $interp \
		[my constString TCL] [my constString LOOKUP] \
		[my constString STACK_LEVEL] $levelstr {}
	    $api Tcl_DecrRefCount $levelobj
	    my ret [my fail STRING]
	}

	##### tcl.callframe.depth #####
	#
	# Type signature: frame:CALLFRAME -> INT
	#
	# Get the call depth (see [info level]) of the given call frame.

	set f [$m local "tcl.callframe.depth" INT<-CALLFRAME]
	params frame
	build {
	    nonnull $frame
	    my ret [my packInt32 [my dereference $frame 0 CallFrame.level]]
	}

	##### var.followLinks #####
	#
	# Type signature: var:Var* -> Var*
	#
	# Given a particular variable, follow its chain of links (which might
	# be none at all) to get to the actual variable holding the real

Changes to demos/pkgs/pkgIndex.tcl.

1
2

package ifneeded cosdemo 0.1 [list source [file join $dir cosdemo.tcl]]
package ifneeded tricky 0.1 [list source [file join $dir trickypkg.tcl]]



>
1
2
3
package ifneeded cosdemo 0.1 [list source [file join $dir cosdemo.tcl]]
package ifneeded tricky 0.1 [list source [file join $dir trickypkg.tcl]]
package ifneeded bonus 0.1 [list source [file join $dir bonus.tcl]]

Changes to quadcode/translate.tcl.

1093
1094
1095
1096
1097
1098
1099











1100
1101
1102
1103
1104
1105
1106
....
1315
1316
1317
1318
1319
1320
1321
1322

1323
1324
1325
1326
1327
1328
1329
		quads extractCallFrame {temp @callframe} {temp @callframe}
		generate-jump [exception-target catch] maybe {temp @error}
	    }
	    currentNamespace {
		quads copy [list temp $depth] \
		    [list literal [dict get $bytecode namespace]]
	    }











	    default {
		# TODO - Many more instructions
		lappend errors $sourcefile $currentline $currentscript \
		    "Bytecode instruction '[lindex $insn 0]'\
                     is not implemented."
	    }
	}
................................................................................
	 uminus [list -  NUMERIC] \
	 bitand [list &  INT] \
	 bitor  [list |  INT] \
	 bitxor [list ^  INT] \
	 mod    [list %  INT] \
	 lshift [list << INT] \
	 rshift [list << INT] \
	 bitnot [list ~  INT]]

proc generate-arith-domain-check {operator args} {
    variable operator_info
    upvar 1 quadindex quadindex fixup fixup quads quads
    set target [uplevel 1 {exception-target catch}]
    if {![dict exists $operator_info $operator]} return
    lassign [dict get $operator_info $operator] opname typename
    namespace upvar quadcode::dataType $typename typecode







>
>
>
>
>
>
>
>
>
>
>







 







|
>







1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
....
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
		quads extractCallFrame {temp @callframe} {temp @callframe}
		generate-jump [exception-target catch] maybe {temp @error}
	    }
	    currentNamespace {
		quads copy [list temp $depth] \
		    [list literal [dict get $bytecode namespace]]
	    }
	    infoLevelArgs {
		set value [list temp [incr depth -1]]
		set r [list temp $depth]
		generate-arith-domain-check [lindex $insn 0] $value
		quads purify {temp opd0} $value
		error-quads frameArgs $r {temp opd0} {temp @callframe}
	    }
	    infoLevelNumber {
		set r [list temp $depth]
		quads frameDepth $r {temp @callframe}
	    }
	    default {
		# TODO - Many more instructions
		lappend errors $sourcefile $currentline $currentscript \
		    "Bytecode instruction '[lindex $insn 0]'\
                     is not implemented."
	    }
	}
................................................................................
	 uminus [list -  NUMERIC] \
	 bitand [list &  INT] \
	 bitor  [list |  INT] \
	 bitxor [list ^  INT] \
	 mod    [list %  INT] \
	 lshift [list << INT] \
	 rshift [list << INT] \
	 bitnot [list ~  INT] \
	 infoLevelArgs [list "info level" INT]]
proc generate-arith-domain-check {operator args} {
    variable operator_info
    upvar 1 quadindex quadindex fixup fixup quads quads
    set target [uplevel 1 {exception-target catch}]
    if {![dict exists $operator_info $operator]} return
    lassign [dict get $operator_info $operator] opname typename
    namespace upvar quadcode::dataType $typename typecode

Changes to quadcode/types.tcl.

544
545
546
547
548
549
550
551

552
553
554
555
556
557
558
...
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
	lshift -
	maptoint -
	returnCode -
	rshift -
	strcmp -
	strfind -
	strlen -
	strrfind {

	    return $INT
	}
	copy {
	    return [typeOfOperand $types [lindex $q 2]]
	}
	purify {
	    return [expr {[typeOfOperand $types [lindex $q 2]] & ~$IMPURE}]
................................................................................
	    set vartype [typeOfOperand $types [lindex $q 2]]
	    set deftype [typeOfOperand $types [lindex $q 3]]
	    return [expr {$deftype | ($vartype & ~$NEXIST)}]
	}
	resolveCmd {
	    return $STRING
	}
	originCmd {
	    return [expr {$STRING | $FAIL}]
	}
	directGet - directSet - directAppend - directLappend {
	    # Can't assume more; these may be touching traced variables
	    return [expr {$STRING | $FAIL}]
	}
	directExists {







|
>







 







|







544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
...
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
	lshift -
	maptoint -
	returnCode -
	rshift -
	strcmp -
	strfind -
	strlen -
	strrfind -
	frameDepth {
	    return $INT
	}
	copy {
	    return [typeOfOperand $types [lindex $q 2]]
	}
	purify {
	    return [expr {[typeOfOperand $types [lindex $q 2]] & ~$IMPURE}]
................................................................................
	    set vartype [typeOfOperand $types [lindex $q 2]]
	    set deftype [typeOfOperand $types [lindex $q 3]]
	    return [expr {$deftype | ($vartype & ~$NEXIST)}]
	}
	resolveCmd {
	    return $STRING
	}
	originCmd - frameArgs {
	    return [expr {$STRING | $FAIL}]
	}
	directGet - directSet - directAppend - directLappend {
	    # Can't assume more; these may be touching traced variables
	    return [expr {$STRING | $FAIL}]
	}
	directExists {