C64-dev/newLang/tests/runtime/lifetime-test.s

; E06-S06: interface lifetime and failure paths in x128.
;
; Runs under CR=$0E with a 4K heap at $4000. It checks:
;   - delete through an interface value calls the class destructor once, frees
;     the complete object, and clears the value so it cannot delete twice;
;   - delete on a canonical null interface value is a no-op;
;   - one object reachable through two interface tables is freed once, and the
;     other value is refused afterwards;
;   - an alias (a copy of the value) that outlives the deletion is a detectable
;     failure: IF_ERR_FREED, no second destructor call, no heap change;
;   - a null interface call faults predictably with IF_ERR_NULL, executes no
;     target, and leaves dispatch working.
;
; MB_DATA flags 0..4 report the five phases.

.setcpu "6502"
.include "../../src/common/c128.inc"
.include "../../src/common/mailbox.inc"
.include "../../src/common/print.inc"
.include "../../src/common/heap.inc"
.include "../../src/common/class.inc"
.include "../../src/common/frames.inc"
.include "../../src/common/interfaces.inc"

.import pr_char, pr_cr, pr_text
.import heap_init, heap_free_total, heap_error
.import frame_init
.import obj_new, obj_init_ptr
.import if_call, if_error
.import if_delete

HEAP_BASE  = $4000
HEAP_PAGES = 16

.macro TEXT src, len
        lda #<src
        ldx #>src
        ldy #len
        jsr pr_text
.endmacro

.macro PHASE n
        lda #n
        sta MB_CODE
        lda #$00
        sta MB_CODE+1
.endmacro

.macro MARK n
        lda #n
        sta MB_ADDR
.endmacro

.macro FAIL_CS
        bcc :+
        jmp @fail
:
.endmacro

.macro FAIL_CC
        bcs :+
        jmp @fail
:
.endmacro

.macro FAIL_NE
        beq :+
        jmp @fail
:
.endmacro

; A word in A/X must equal the two bytes at addr.
.macro CHK_WORD addr
        cmp addr
        bne @bad
        txa
        cmp addr+1
        beq @ok
@bad:   jmp @fail
@ok:
.endmacro

.segment "LOADADDR"
        .word $1C01

.segment "EXEHDR"
        .word basic_end
        .word 10
        .byte $9E
        .byte "7181"
        .byte $00
basic_end:
        .word $0000

.segment "MAILBOX"
        .res MB_SIZE

.segment "STARTUP"
.export test_entry, test_end
test_entry:
        php
        sei
        ldx #MB_SIZE - 1
        lda #$00
@clr:   sta MB_BASE,x
        dex
        bpl @clr
        lda #MB_MAGIC0_VALUE
        sta MB_MAGIC0
        lda #MB_MAGIC1_VALUE
        sta MB_MAGIC1
        lda #MB_PROD_PROGRAM
        sta MB_PRODUCER
        lda #MB_ST_RUNNING
        sta MB_STATUS
        lda #$00
        sta MB_CODE
        sta MB_CODE+1
        sta destroy_count
        sta hit_count
        ldx #$04
@flags: sta MB_DATA,x
        dex
        bpl @flags

        lda MMU_CR
        sta saved_cr
        lda #CR_RAM0_KERNAL
        sta MMU_CR
        lda #PR_CLEAR
        jsr pr_char
        TEXT title, title_len
        jsr pr_cr

        PHASE 1
        lda #$00
        ldx #>HEAP_BASE
        ldy #HEAP_PAGES
        jsr heap_init
        FAIL_CS
        MARK $01
        jsr frame_init
        lda #$00
        sta obj_init_ptr
        sta obj_init_ptr+1

        ; 1: delete through an interface frees once and clears the value.
        MARK $02
        lda #<desc_life
        ldx #>desc_life
        jsr obj_new
        FAIL_CS
        sta live_obj
        stx live_obj+1
        jsr make_foo
        MARK $03
        lda #<val_foo
        ldx #>val_foo
        jsr if_delete
        bcc :+
        lda if_error
        sta MB_CODE
        lda #$08
        sta MB_ADDR
        jmp @fail
:       MARK $04
        lda if_error
        FAIL_NE
        lda destroy_count
        cmp #1
        FAIL_NE
        MARK $05
        lda destroy_self
        cmp live_obj
        FAIL_NE
        lda destroy_self+1
        cmp live_obj+1
        FAIL_NE
        lda heap_free_total
        cmp #$00
        FAIL_NE
        lda heap_free_total+1
        cmp #$10
        FAIL_NE
        MARK $06
        jsr chk_zero
        FAIL_CS
        MARK $07
        lda #$01
        sta MB_DATA+0

        ; 2: delete on a canonical null value is a no-op.
        PHASE 2
        MARK $11
        ; BSS is not part of the PRG image, so state the null values here.
        ldx #$03
        lda #$00
@init2: sta val_null,x
        sta val_objnull,x
        dex
        bpl @init2
        lda #$C0
        sta val_objnull+IF_TABLE
        lda #<val_null
        ldx #>val_null
        jsr if_delete
        FAIL_CS
        MARK $12
        lda if_error
        FAIL_NE
        lda destroy_count
        cmp #1
        FAIL_NE
        ; A value with a table but no object is still null for deletion.
        lda #<val_objnull
        ldx #>val_objnull
        jsr if_delete
        FAIL_CS
        lda destroy_count
        cmp #1
        FAIL_NE
        lda #$01
        sta MB_DATA+1

        ; 3: one object, two interface tables: the first delete frees it, the
        ; second value is refused rather than reading a freed destructor.
        PHASE 3
        lda #<desc_life
        ldx #>desc_life
        jsr obj_new
        FAIL_CS
        sta live_obj
        stx live_obj+1
        jsr make_foo
        lda live_obj
        sta val_bar
        lda live_obj+1
        sta val_bar+1
        lda #<tab_bar
        sta val_bar+IF_TABLE
        lda #>tab_bar
        sta val_bar+IF_TABLE+1
        lda #<val_bar
        ldx #>val_bar
        jsr if_delete
        FAIL_CS
        lda destroy_count
        cmp #2
        FAIL_NE
        lda heap_free_total+1
        cmp #$10
        FAIL_NE
        lda #<val_foo
        ldx #>val_foo
        jsr if_delete
        FAIL_CC
        lda if_error
        cmp #IF_ERR_FREED
        FAIL_NE
        lda destroy_count
        cmp #2
        FAIL_NE
        lda heap_free_total+1
        cmp #$10
        FAIL_NE
        lda #$01
        sta MB_DATA+2

        ; 4: an alias copy that outlives the deletion is detected.
        PHASE 4
        lda #<desc_life
        ldx #>desc_life
        jsr obj_new
        FAIL_CS
        sta live_obj
        stx live_obj+1
        jsr make_foo
        ldx #$00
@alias: lda val_foo,x
        sta val_alias,x
        inx
        cpx #IF_VALUE_SIZE
        bne @alias
        lda #<val_foo
        ldx #>val_foo
        jsr if_delete
        FAIL_CS
        lda destroy_count
        cmp #3
        FAIL_NE
        lda #<val_alias
        ldx #>val_alias
        jsr if_delete
        FAIL_CC
        lda if_error
        cmp #IF_ERR_FREED
        FAIL_NE
        lda destroy_count
        cmp #3
        FAIL_NE
        lda heap_free_total
        cmp #$00
        FAIL_NE
        lda heap_free_total+1
        cmp #$10
        FAIL_NE
        lda #$01
        sta MB_DATA+3

        ; 5: a null call faults before any target runs, and dispatch recovers.
        PHASE 5
        lda #<val_null
        ldx #>val_null
        ldy #$00
        jsr if_call
        FAIL_CC
        lda if_error
        cmp #IF_ERR_NULL
        FAIL_NE
        lda hit_count
        FAIL_NE

        lda #<desc_life
        ldx #>desc_life
        jsr obj_new
        FAIL_CS
        sta live_obj
        stx live_obj+1
        jsr make_foo
        lda #<val_foo
        ldx #>val_foo
        ldy #$00
        jsr if_call
        FAIL_NE
        lda if_error
        FAIL_NE
        lda hit_count
        cmp #1
        FAIL_NE
        lda #<val_foo
        ldx #>val_foo
        jsr if_delete
        FAIL_CS
        lda destroy_count
        cmp #4
        FAIL_NE
        lda #$01
        sta MB_DATA+4

        TEXT ok_msg, ok_len
        jsr pr_cr
        lda #MB_ST_PASS
        sta MB_STATUS
        lda #$00
        sta MB_CODE
        sta MB_CODE+1
        jmp @restore

@fail:
        lda #MB_ST_FAIL
        sta MB_STATUS
        TEXT fail_msg, fail_len
        jsr pr_cr
@restore:
        lda saved_cr
        sta MMU_CR
        plp
        rts

; val_foo = live_obj + tab_foo.
make_foo:
        lda live_obj
        sta val_foo
        lda live_obj+1
        sta val_foo+1
        lda #<tab_foo
        sta val_foo+IF_TABLE
        lda #>tab_foo
        sta val_foo+IF_TABLE+1
        rts

; C=1 unless the four bytes at val_foo are zero.
chk_zero:
        ldx #$00
@z:     lda val_foo,x
        bne @nz
        inx
        cpx #IF_VALUE_SIZE
        bne @z
        clc
        rts
@nz:    sec
        rts

.segment "CODE"
; Destructor: records how often and for which object it ran.
destroy_life:
        sta destroy_self
        stx destroy_self+1
        inc destroy_count
        rts

; Slot 0 target used by the null-call check.
m_hit:
        inc hit_count
        lda #$11
        ldx #$00
        rts

.segment "DATA"
desc_life:
        .word 4                    ; header + one word field
        .word destroy_life
        .byte 0
        .word 0
        .byte 0
.assert * - desc_life = CLASS_DESC_SIZE, error, "life descriptor size"

tab_foo:        .word m_hit
tab_bar:        .word m_hit
.assert tab_bar - tab_foo = IF_SLOT_SIZE, error, "one slot per table"

.segment "RODATA"
title:          .byte "NOVA128 LIFETIME TEST"
title_len = * - title
ok_msg:         .byte "LIFETIME OK"
ok_len = * - ok_msg
fail_msg:       .byte "LIFETIME FAIL"
fail_len = * - fail_msg

.segment "BSS"
saved_cr:       .res 1
live_obj:       .res 2
destroy_count:  .res 1
destroy_self:   .res 2
hit_count:      .res 1
val_foo:        .res IF_VALUE_SIZE
val_bar:        .res IF_VALUE_SIZE
val_alias:      .res IF_VALUE_SIZE
val_null:       .res IF_VALUE_SIZE
val_objnull:    .res IF_VALUE_SIZE
test_end: