tclquadcode

Check-in [89816c024e]
Login

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

Overview
Comment:Working towards using the lifetime information. Also move the cast-to-STRING code into the type-cast builder.
Timelines: family | ancestors | descendants | both | llvm-integration-memory
Files: files | file ages | folders
SHA1:89816c024eb4e4f7b3cd10b3592688e3be7b74ca
User & Date: dkf 2015-03-08 15:28:18
Context
2015-03-10
14:51
Merge the code to generate the lifetimes from the model check-in: a7682cd36e user: dkf tags: llvm-integration-memory
2015-03-08
16:52
Merge the code to generate the lifetimes from the model; [6d228ecd45] crashes due to type problems... check-in: 3b984c101d user: dkf tags: llvm-integration-memory-part2
15:28
Working towards using the lifetime information. Also move the cast-to-STRING code into the type-cast builder. check-in: 89816c024e user: dkf tags: llvm-integration-memory
2015-03-07
20:00
Improved algorithm for determining variable lifespans in loops. Probably still buggy, but might be good enough to go to using the info. check-in: af57270212 user: dkf tags: llvm-integration-memory
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to codegen/build.tcl.

351
352
353
354
355
356
357
358
359
360














361
362
363


364
365
366

367

368
369
370
371

372
373
374
375
376




377
378



379
380
381
382
383
384
385
...
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
    method MakeTypecastWrapper {signature} {
	# This method inserts casts to lift INT to DOUBLE as necessary,
	# provided there is a way of generating the instruction with
	# DOUBLE in the first place.
	if {![regexp {^([^()]+)\(([\w,]+)\)$} $signature -> name types]} {
	    return 0
	}
	# FIXME: Awful hack because we don't handle STRING correctly yet
	set n ${name}([regsub -all {\w+} [string map {STRING INT} $types] DOUBLE])
	if {$n ni [info class methods [self class]]} {














	    return 0
	}



	set num [llength [set types [split $types ,]]]
	set formals [lindex [info class definition [self class] $n] 0]
	set body "my $n"

	foreach t $types f [lrange $formals 0 [expr {$num-1}]] {

	    if {$t eq "DOUBLE"} {
		append body { $} [lindex $f 0]
	    } else {
		append body { [my cast(DOUBLE) $} [lindex $f 0] { cast]}

	    }
	}
	foreach f [lrange $formals $num end] {
	    append body { $} [lindex $f 0]
	}




	oo::objdefine [self] method $signature $formals $body
	return 1



    }

    method add {left right {name ""}} {
	BuildAdd $b $left $right $name
    }
    method add(INT,INT) {left right {name ""}} {
	my call ${tcl.add} [list $left $right] $name
................................................................................
	my call ${tcl.stringify.double} [list $value] $name
	# WARNING allocates memory
    }
    method stringify(INT) {value {name ""}} {
	my call ${tcl.stringify.int} [list $value] $name
	# WARNING allocates memory
    }
    method strlen {value {name ""}} {
	my call ${tcl.strlen} [list $value] $name
    }

    method sub {left right {name ""}} {
	BuildSub $b $left $right $name
    }
    method sub(INT,INT) {left right {name ""}} {







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


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







 







|







351
352
353
354
355
356
357

358
359
360
361
362
363
364
365
366
367
368
369
370
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
403
404
405
406
407
408
...
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
    method MakeTypecastWrapper {signature} {
	# This method inserts casts to lift INT to DOUBLE as necessary,
	# provided there is a way of generating the instruction with
	# DOUBLE in the first place.
	if {![regexp {^([^()]+)\(([\w,]+)\)$} $signature -> name types]} {
	    return 0
	}

	set n ${name}([regsub -all {\w+} $types DOUBLE])
	if {$n in [info class methods [self class]]} {
	    set num [llength [set types [split $types ,]]]
	    set formals [lindex [info class definition [self class] $n] 0]
	    set body "my $n"
	    foreach t $types f [lrange $formals 0 [expr {$num-1}]] {
		if {$t eq "DOUBLE"} {
		    append body { $} [lindex $f 0]
		} else {
		    append body { [my cast(DOUBLE) $} [lindex $f 0] { cast]}
		}
	    }
	    foreach f [lrange $formals $num end] {
		append body { $} [lindex $f 0]
	    }
	    oo::objdefine [self] method $signature $formals $body
	    return 1
	}

	set n ${name}([regsub -all {\w+} $types STRING])
	if {$n in [info class methods [self class]]} {
	    set num [llength [set types [split $types ,]]]
	    set formals [lindex [info class definition [self class] $n] 0]

	    set body "set casts {}; set result \[my $n"
	    foreach t $types f [lrange $formals 0 [expr {$num-1}]] {
		set var [lindex $f 0]
		if {$t eq "STRING"} {
		    append body { $} $var
		} else {

		    append body { [set val [} "my stringify($t) $$var" {]; lappend casts $val; set val]}
		}
	    }
	    foreach f [lrange $formals $num end] {
		append body { $} [lindex $f 0]
	    }
	    append body "\];" {
		foreach cast $casts {my dropReference $cast}
		return $result
	    }
	    oo::objdefine [self] method $signature $formals $body
	    return 1
	}

	return 0
    }

    method add {left right {name ""}} {
	BuildAdd $b $left $right $name
    }
    method add(INT,INT) {left right {name ""}} {
	my call ${tcl.add} [list $left $right] $name
................................................................................
	my call ${tcl.stringify.double} [list $value] $name
	# WARNING allocates memory
    }
    method stringify(INT) {value {name ""}} {
	my call ${tcl.stringify.int} [list $value] $name
	# WARNING allocates memory
    }
    method strlen(STRING) {value {name ""}} {
	my call ${tcl.strlen} [list $value] $name
    }

    method sub {left right {name ""}} {
	BuildSub $b $left $right $name
    }
    method sub(INT,INT) {left right {name ""}} {

Changes to codegen/compile.tcl.

504
505
506
507
508
509
510
511

512
513
514
515
516
517
518
...
549
550
551
552
553
554
555

556

557
558
559
560
561
562
563
564
565
566
567




568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591

592
593
594
595
596
597
598
599
600
601

602
603
604
605
606

607
608
609
610
611
612
613


614
615
616
617
618
619
620
...
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679

680
681
682
683
684
685
686
687
688
689










690
691
692
693
694
695
696
		if {![info exists block($tgt)]} {
		    set block($tgt) [$func block]
		}
		set next_is_ipath $pc
	    }
	}
	$block(-1) build-in $b
	my PropagatesVariables [array names block]


	# Create stack and stack pointer
	set stack [Stack new $b $stackDepth]
	set curr_block $block(-1)
	set ends_with_jump($curr_block) 0
	set 0 [$b packInt32 [Const 0]]

................................................................................
	set maxpc 0
	set pc -1
	foreach l $quads {
	    incr pc
	    set opcode [lindex $l 0]
	    set maxpc $pc
	    if {[info exists block($pc)]} {

		$block($pc) build-in $b

		set curr_block $block($pc)
		set block_finished 0
	    }
	    if {$block_finished} {
		# Instructions after something that terminates a block
		# should be ignored. Tcl's built-in optimizer doesn't trim
		# all of them.
		continue
	    }
	    set ends_with_jump($curr_block) 0
	    unset -nocomplain tgt





	    switch -exact -- $opcode {
		"confluence" {
		    # Do nothing; required for SSA computations only
		}
		"bitor" - "bitxor" - "bitand" - "lshift" - "rshift" -
		"add" - "sub" - "mult" - "div" - "mod" - "uminus" -
		"bitnot" {
		    my SimpleOp $b $l
		}
		"eq" - "neq" - "lt" - "gt" - "le" - "ge" {
		    my CompareOp $b $l
		}
		"copy" {
		    lassign $l opcode tgt src
		    my StoreResult $tgt [my LoadOrLiteral $src]
		}

		"jumpTrue" {
		    lassign $l opcode tgt src
		    set name [my LocalVarName $src]
		    set tgt [lindex $tgt 1]
		    set neq neq([my ValueTypes $src],INT)
		    $b condBr(INT) [$b $neq [my LoadOrLiteral $src] $0 test_$name] \

			$block($tgt) $block($ipath($pc))
		    set ends_with_jump($curr_block) 1
		    set block_finished 1
		}
		"jumpFalse" {
		    lassign $l opcode tgt src
		    set name [my LocalVarName $src]
		    set tgt [lindex $tgt 1]
		    set neq neq([my ValueTypes $src],INT)
		    $b condBr(INT) [$b $neq [my LoadOrLiteral $src] $0 test_$name] \

			$block($ipath($pc)) $block($tgt)
		    set ends_with_jump($curr_block) 1
		    set block_finished 1
		}
		"jump" {

		    $b br $block([lindex $l 1 1])
		    set ends_with_jump($curr_block) 1
		    set block_finished 1
		}
		"return" {
		    lassign $l opcode -> src
		    $b ret [my LoadOrLiteral $src]


		    set ends_with_jump($curr_block) 1
		    set block_finished 1
		}
		"phi" {
		    set values {}
		    set sources {}
		    foreach {var origin} [lassign $l opcode tgt] {
................................................................................
			error "unknown function \"$origname\""
		    }
		    set called [[$module function.get $name] ref]
		    set arguments [lmap arg $arguments {my LoadOrLiteral $arg}]
		    set name [my LocalVarName $tgt]
		    my StoreResult $tgt [$b call $called $arguments $name]
		}
		"streq" {
		    set srcs [lassign $l opcode tgt]
		    set name [my LocalVarName $tgt]
		    set casts {}
		    set arguments [lmap src $srcs {
			my CastToString $b $src [my LoadOrLiteral $src]
		    }]
		    set result [$b streq {*}$arguments $name]
		    my StoreResult $tgt [$b cast(BOOLEAN) $result ${name}_ext]
		    foreach val $casts {
			my ReleaseString $b $val
		    }
		}
		"strlen" {
		    lassign $l opcode tgt src
		    set arg [my LoadOrLiteral $src]
		    set casts {}
		    set argument [my CastToString $b $src $arg]
		    set name [my LocalVarName $tgt]
		    my StoreResult $tgt [$b strlen $argument $name]
		    foreach val $casts {
			my ReleaseString $b $val
		    }
		}
		default {
		    error "unknown bytecode '$opcode' in '$l'"
		}
	    }
	}

	# Set increment paths
	foreach {pc blk} [array get block] {
	    $blk build-in $b
	    if {$ends_with_jump($blk)} continue
	    while {[incr pc] <= $maxpc} {
		if {[info exists block($pc)]} {

		    $b br $block($pc)
		    break
		}
	    }
	}

	# Cleanup and return
	$stack destroy
	return [$func ref]
    }











    method SimpleOp {b l} {
	set srcs [lassign $l opcode tgt]
	set name [my LocalVarName $tgt]
	append opcode ( [my ValueTypes {*}$srcs] )
	set result [$b $opcode {*}[lmap s $srcs {my LoadOrLiteral $s}] $name]
	my StoreResult $tgt $result







|
>







 







>

>











>
>
>
>







|


|












|
>
|








|
>
|




>






|
>
>







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












>










>
>
>
>
>
>
>
>
>
>







504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
...
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
...
649
650
651
652
653
654
655
























656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
		if {![info exists block($tgt)]} {
		    set block($tgt) [$func block]
		}
		set next_is_ipath $pc
	    }
	}
	$block(-1) build-in $b
	lassign [my PropagatesVariables [array names block]] \
	    unsetstart unsetend

	# Create stack and stack pointer
	set stack [Stack new $b $stackDepth]
	set curr_block $block(-1)
	set ends_with_jump($curr_block) 0
	set 0 [$b packInt32 [Const 0]]

................................................................................
	set maxpc 0
	set pc -1
	foreach l $quads {
	    incr pc
	    set opcode [lindex $l 0]
	    set maxpc $pc
	    if {[info exists block($pc)]} {
		set unsetsToProcess [dict get $unsetstart $pc]
		$block($pc) build-in $b
		set unsetsAtEnd [dict get $unsetend $pc]
		set curr_block $block($pc)
		set block_finished 0
	    }
	    if {$block_finished} {
		# Instructions after something that terminates a block
		# should be ignored. Tcl's built-in optimizer doesn't trim
		# all of them.
		continue
	    }
	    set ends_with_jump($curr_block) 0
	    unset -nocomplain tgt
	    if {[info exist unsetsToProcess] && $opcode ni {confluence phi}} {
		my ProcessUnsets $unsetsToProcess
		unset unsetsToProcess
	    }

	    switch -exact -- $opcode {
		"confluence" {
		    # Do nothing; required for SSA computations only
		}
		"bitor" - "bitxor" - "bitand" - "lshift" - "rshift" -
		"add" - "sub" - "mult" - "div" - "mod" - "uminus" -
		"bitnot" - "strlen" {
		    my SimpleOp $b $l
		}
		"eq" - "neq" - "lt" - "gt" - "le" - "ge" - "streq" {
		    my CompareOp $b $l
		}
		"copy" {
		    lassign $l opcode tgt src
		    my StoreResult $tgt [my LoadOrLiteral $src]
		}

		"jumpTrue" {
		    lassign $l opcode tgt src
		    set name [my LocalVarName $src]
		    set tgt [lindex $tgt 1]
		    set neq neq([my ValueTypes $src],INT)
		    set test [$b $neq [my LoadOrLiteral $src] $0 test_$name]
		    my ProcessUnsets $unsetsAtEnd
		    $b condBr(INT) $test $block($tgt) $block($ipath($pc))
		    set ends_with_jump($curr_block) 1
		    set block_finished 1
		}
		"jumpFalse" {
		    lassign $l opcode tgt src
		    set name [my LocalVarName $src]
		    set tgt [lindex $tgt 1]
		    set neq neq([my ValueTypes $src],INT)
		    set test [$b $neq [my LoadOrLiteral $src] $0 test_$name]
		    my ProcessUnsets $unsetsAtEnd
		    $b condBr(INT) $test $block($ipath($pc)) $block($tgt)
		    set ends_with_jump($curr_block) 1
		    set block_finished 1
		}
		"jump" {
		    my ProcessUnsets $unsetsAtEnd
		    $b br $block([lindex $l 1 1])
		    set ends_with_jump($curr_block) 1
		    set block_finished 1
		}
		"return" {
		    lassign $l opcode -> src
		    set val [my LoadOrLiteral $src]
		    my ProcessUnsets $unsetsAtEnd
		    $b ret $val
		    set ends_with_jump($curr_block) 1
		    set block_finished 1
		}
		"phi" {
		    set values {}
		    set sources {}
		    foreach {var origin} [lassign $l opcode tgt] {
................................................................................
			error "unknown function \"$origname\""
		    }
		    set called [[$module function.get $name] ref]
		    set arguments [lmap arg $arguments {my LoadOrLiteral $arg}]
		    set name [my LocalVarName $tgt]
		    my StoreResult $tgt [$b call $called $arguments $name]
		}
























		default {
		    error "unknown bytecode '$opcode' in '$l'"
		}
	    }
	}

	# Set increment paths
	foreach {pc blk} [array get block] {
	    $blk build-in $b
	    if {$ends_with_jump($blk)} continue
	    while {[incr pc] <= $maxpc} {
		if {[info exists block($pc)]} {
		    my ProcessUnsets $unsetsAtEnd
		    $b br $block($pc)
		    break
		}
	    }
	}

	# Cleanup and return
	$stack destroy
	return [$func ref]
    }

    method ProcessUnsets {unsetList} {
	upvar 1 b b
	foreach var $unsetList {
	    set type [nameOfType [typeOfOperand $vtypes $var]]
	    if {$type ni {INT {INT BOOLEAN} DOUBLE}} {
		$b dropReference $variables($var)
	    }
	}
    }

    method SimpleOp {b l} {
	set srcs [lassign $l opcode tgt]
	set name [my LocalVarName $tgt]
	append opcode ( [my ValueTypes {*}$srcs] )
	set result [$b $opcode {*}[lmap s $srcs {my LoadOrLiteral $s}] $name]
	my StoreResult $tgt $result