.data
.align 2
heap:
.space 0x80000 # 512KiB
.align 1
_cINT:
.byte 0 # pointer arity
.byte 1 # basic value arity
.byte 0 # number of arguments that still have to be curried in
.align 1
_cCHAR:
.byte 0 # pointer arity
.byte 1 # basic value arity
.byte 0 # number of arguments that still have to be curried in
.align 2
PRINTROOT:
.word _nroot
.word 0 # to be filled in
EVALROOT:
.word _nroot
.word 0 # to be filled in
.text
main:
la $gp,heap
la $t0,__main_nmain
sw $t0,($gp)
la $s0,PRINTROOT
ori $s1,$gp,0
sw $s1,4($s0)
jal driver
addi $gp,$gp,8
li $a0,'\n'
li $v0,11 # print_char
syscall
li $v0,10 # exit
syscall
driver:
addi $sp,$sp,-4
sw $ra,($sp)
la $s7,0x10000000 # end of text section / begin of data section
print:
lw $t0,($s1)
sltu $t0,$t0,$s7
beq $t0,$0,print_hnf
nop
la $s2,EVALROOT
addi $s3,$s1,0
sw $s3,4($s2)
jal eval
nop
addi $s1,$s3,0
print_hnf:
lw $t0,($s1)
la $t1,_cINT
beq $t0,$t1,print_int
la $t1,_cCHAR
beq $t0,$t1,print_char
li $a0,'('
li $v0,11 # print_char
syscall
lbu $t3,($t0) # arity
beq $t3,$0,print_rewind
# continue with printing the arguments
addi $t2,$s0,1
addi $s0,$s1,0
lw $s1,4($s1)
sw $t2,4($s0)
b print
nop
print_int:
lw $a0,4($s1)
li $v0,1 # print_int
syscall
b print_rewind
nop
print_char:
li $a0,39 # '
li $v0,11 # print_char
syscall
lw $a0,4($s1)
li $v0,11 # print_char
syscall
li $a0,39 # '
li $v0,11 # print_char
syscall
b print_rewind
nop
print_rewind:
la $t5,PRINTROOT
beq $s0,$t5,print_rewind_root
addi $t0,$s0,0
addi $t1,$s0,0 # argument pointer
lw $t2,($t0)
lbu $t2,($t2) # arity
print_rewind_loop:
addi $t1,$t1,4
lw $t3,($t1)
andi $t4,$t3,1
beq $t4,$0,print_rewind_loop
addi $t2,$t2,-1
# we have found the argument that was being printed
beq $t2,$0,print_rewind_done
# there is a next argument to print
li $a0,','
li $v0,11 # print_char
syscall
sw $s1,($t1)
lw $s1,4($t1)
sw $t3,4($t1)
b print
nop
print_rewind_done:
# this node is fully printed; go up to the parent
li $a0,')'
li $v0,11 # print_char
syscall
xori $s0,$t3,1
sw $s1,($t1)
addi $s1,$t0,0
j print_rewind
nop
print_rewind_root:
lw $ra,($sp)
jr $ra
addi $sp,$sp,4
eval:
lw $t0,($s3)
# Exit early in case of hnf
sltu $t1,$t0,$s7
beq $t1,$0,eval_rewind
# Walk through indirections
la $t1,_nindir
bne $t0,$t1,eval_indir_done
addi $t2,$s3,0
eval_indir:
lw $s3,4($s3)
lw $t0,($s3)
beq $t0,$t1,eval_indir
sw $s3,4($t2) # update original indir; optimizes chained indirs
# Check again for hnf
sltu $t1,$t0,$s7
beq $t1,$0,eval_rewind
nop
eval_indir_done:
lbu $t1,-1($t0) # load arity
lbu $t2,-2($t0) # strictness
addi $t3,$s3,4 # argument pointer
eval_arg_loop:
beq $t1,$0,eval_args_done
andi $t4,$t2,1
bne $t4,$0,eval_arg_strict
srl $t2,$t2,1
addi $t1,$t1,-1
j eval_arg_loop
addi $t3,$t3,4
eval_arg_strict:
lw $t4,($t3)
lw $t5,($t4)
sltu $t5,$t5,$s7 # check if argument is already in hnf
bne $t5,$0,eval_arg
addi $t1,$t1,-1
j eval_arg_loop
addi $t3,$t3,4
eval_arg:
addi $s2,$s2,1 # reverse pointers
sw $s2,($t3)
addi $s2,$s3,0
addi $s3,$t4,0
j eval # continue evaluating argument
nop
eval_args_done:
jr $t0
nop
eval_rewind:
la $t4,EVALROOT
beq $s2,$t4,eval_rewind_root
addi $t0,$s2,0
addi $t1,$s2,4
eval_rewind_loop:
lw $t2,($t1)
andi $t3,$t2,1
beq $t3,$0,eval_rewind_loop
addi $t1,$t1,4
xori $s2,$t2,1
sw $s3,-4($t1)
addi $s3,$t0,0
j eval
nop
eval_rewind_root:
jr $ra
nop
.data
cycle_error:
.asciiz "error: cycle in spine detected\n"
.text
#.align 1
#.byte 0 # strictness
#.byte 1 # arity
# TODO: we cannot use the above because SPIM does not accept .byte in text section
.align 2
.word 0x01000000 # arity, strictness
_nroot:
la $a0,cycle_error
li $v0,4 # print_string
syscall
break 0
.data
indir_error:
.asciiz "error: indirection evaluated\n"
.text
#.align 1
#.byte 0x1 # strictness
#.byte 1 # arity
# TODO: we cannot use the above because SPIM does not accept .byte in text section
.align 2
.word 0x01010000 # arity, strictness
_nindir:
# indirections are handled in eval
la $a0,indir_error
li $v0,4 # print_string
syscall
break 0
#.align 1
#.byte 0x3 # strictness (incorrect; see documentation)
#.byte 2 # arity
# TODO: we cannot use the above because SPIM does not accept .byte in text section
.align 2
.word 0x02030000 # arity, strictness
_nap:
# 4($s3) is closure to apply
# 8($s3) is argument
# NB: assumption: the closure has no basic value arguments
lw $t0,4($s3) # t0 -> closure
lw $t1,($t0) # t1 -> closure descriptor
lbu $t2,($t1) # t2 = closure arity
# TODO: check heap space
# Create new closure: copy old closure
addi $t3,$t1,4 # t3 -> next closure descriptor
addi $t5,$gp,0 # t5 -> new closure
sw $t3,($gp)
addi $t6,$t0,4 # closure argument iterator
_nap_copy:
beq $t2,$0,_nap_copy_done
addi $gp,$gp,4 # branch delay slot
lw $t4,($t6) # t4 -> closure argument
addi $t6,$t6,4
sw $t4,($gp)
j _nap_copy
addi $t2,$t2,-1 # branch delay slot
_nap_copy_done:
# Add new argument
lw $t0,8($s3) # t0 -> new argument
sw $t0,($gp)
addi $gp,$gp,4
# Check if the closure is saturated
lbu $t2,2($t1) # t2 = number of remaining closure arguments - 1
bne $t2,$0,_nap_no_eval
# Saturated; create thunk
lw $t3,($t3) # function address
sw $t3,($t5)
_nap_no_eval:
# Create indirection
la $t0,_nindir
sw $t0,($s3)
sw $t5,4($s3)
addi $s3,$t5,0
j eval
nop
