path: root/plusplus.s

#define $hp	$gp
#define $print_back	$s0
#define $print_front	$s1
#define $eval_back	$s2
#define $eval_front	$s3

	.data
	.align	2
CONS:
	.word	2	# arity
	.word	4	# name
	.ascii	"Cons"

	.align 2
NIL:
	.word	0	# arity
	.word	3	# name
	.ascii	"Nil"

	.align 2
INT:
	.word	0x100	# arity
	.word	3	# name
	.ascii	"Int"

	.align 2
PRINTROOT:
	.word	root
	.word	0	# to be filled in
EVALROOT:
	.word	root
	.word	0	# to be filled in

	.align 2
heap:

	.text
main:
	la	$gp,heap

	# NIL @ hp[0]
	la	$t0,NIL+2
	sw	$t0,($gp)
	# INT 5 @ hp[4]
	la	$t0,INT+2
	sw	$t0,4($gp)
	ori	$t0,$0,5
	sw	$t0,8($gp)
	# x = cons (INT 5) NIL @ hp[12]
	la	$t0,cons
	sw	$t0,12($gp)
	addi	$t0,$gp,4
	sw	$t0,16($gp)
	addi	$t0,$gp,0
	sw	$t0,20($gp)
	# y = plusplus x x @ hp[24]
	la	$t0,plusplus
	sw	$t0,24($gp)
	addi	$t0,$gp,12
	sw	$t0,28($gp)
	sw	$t0,32($gp)
	# z = plusplus y y @ hp[36]
	la	$t0,plusplus
	sw	$t0,36($gp)
	addi	$t0,$gp,24
	sw	$t0,40($gp)
	sw	$t0,44($gp)
	# a = plusplus z z @ hp[48]
	la	$t0,plusplus
	sw	$t0,48($gp)
	addi	$t0,$gp,36
	sw	$t0,52($gp)
	sw	$t0,56($gp)

	la	$s0,PRINTROOT
	addi	$s1,$gp,48	# node to eval
	sw	$s1,4($s0)

	jal	driver
	addi	$gp,$gp,60

	li	$a0,'\n'
	li	$v0,11	# print_char
	syscall
	li	$v0,10	# exit
	syscall

driver:
	addi	$sp,$sp,-4
	sw	$ra,($sp)
print:
	lw	$t0,($s1)
	andi	$t0,$t0,2
	bne	$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,INT+2
	beq	$t0,$t1,print_int
	lw	$t1,2($t0)	# name length
	addi	$t2,$t0,6	# name
	add	$t1,$t1,$t2
print_cons:
	lw	$t3,-2($t0)	# arity
	beq	$t3,$0,print_cons_no_paren
	li	$a0,'('
	li	$v0,11	# print_char
	syscall
print_cons_no_paren:
	lb	$a0,($t2)
	li	$v0,11	# print_char
	syscall
	addi	$t2,$t2,1
	bne	$t1,$t2,print_cons_no_paren
	nop
	beq	$t3,$0,print_rewind
	li	$a0,' '
	li	$v0,11	# print_char
	syscall
	# continue with printing the arguments
	addi	$t2,$s0,1
	addi	$s0,$s1,0
	lw	$s1,4($s1)
	sw	$t2,4($s0)
	j	print
	nop

print_int:
	lw	$a0,4($s1)
	li	$v0,1	# print_int
	syscall
	j	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)
	lw	$t2,-2($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)
	j	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
	andi	$t1,$t0,2
	bne	$t1,$0,eval_rewind
	# Walk through indirections
	la	$t1,indir
	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
	andi	$t1,$t0,2
	bne	$t1,$0,eval_rewind
	nop
eval_indir_done:
	lw	$t1,-4($t0)	# load arity
	lw	$t2,-8($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	$t4,($t4)
	andi	$t4,$t4,2
	beq	$t4,$0,eval_arg
	addi	$t1,$t1,-1
	j	eval_arg_loop
	addi	$t3,$t3,4
eval_arg:
	lw	$t4,($t3)	# reverse pointers
	addi	$s2,$s2,1
	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,0
eval_rewind_loop:
	addi	$t1,$t1,4
	lw	$t2,($t1)
	andi	$t3,$t2,1
	beq	$t3,$0,eval_rewind_loop
	nop
	xori	$s2,$t2,1
	sw	$s3,($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
	.word	0	# strictness
	.word	1	# arity
root:
	la	$a0,cycle_error
	li	$v0,4	# print_string
	syscall
	break	0

	.data
indir_error:
	.asciiz	"error: indirection evaluated\n"
	.text
	.word	0x1	# strictness
	.word	1	# arity
indir:
	# indirections are handled in eval
	la	$a0,indir_error
	li	$v0,4	# print_string
	syscall
	break	0

	.word	0x1	# strict in 1st argument
	.word	2	# arity
plusplus:
	lw	$t0,4($s3)	# xs
	lw	$t1,($t0)
	la	$t2,NIL+2
	beq	$t1,$t2,plusplus_nil
	nop
	# TODO check heap space
	lw	$t1,4($t0)	# hd xs
	lw	$t2,8($t0)	# tl xs
	lw	$t3,8($s3)	# ys
	# Build node: (++ (tl xs) ys)
	la	$t0,plusplus
	sw	$t0,($gp)
	sw	$t2,4($gp)
	sw	$t3,8($gp)
	# Build node: CONS (hd xs) (++ (tl xs) ys)
	la	$t0,CONS+2
	sw	$t0,12($gp)
	sw	$t1,16($gp)
	sw	$gp,20($gp)
	# Update front and heap pointers
	addi	$s3,$gp,12
	j	eval
	addi	$gp,$gp,24
plusplus_nil:
	# indirect to second argument
	la	$t0,indir
	sw	$t0,($s3)
	lw	$t0,8($s3)
	sw	$t0,4($s3)
	addi	$s3,$t0,0
	j	eval
	nop

	.word	0x3	# strict in 1st and 2nd argument
	.word	2	# arity
cons:
	# TODO check heap space
	# Create new CONS node with same arguments
	la	$t0,CONS+2
	lw	$t1,4($s3)
	lw	$t2,8($s3)
	sw	$t0,($gp)
	sw	$t1,4($gp)
	sw	$t2,8($gp)
	# Overwrite original cons node with indirection
	la	$t0,indir
	sw	$t0,($s3)
	sw	$gp,4($s3)
	# Update front and heap pointers
	addi	$s3,$gp,0
	j	eval
	addi	$gp,$gp,12