6502/PLASMA
1
0
Fork 0
mirror of https://github.com/dschmenk/PLASMA.git synced 2025-01-22 23:29:55 +00:00
Code Issues Projects Releases Wiki Activity

Add more looping options and clean up GC in-flight sweeping

Browse Source
This commit is contained in:
David Schmenk 2024-07-18 07:52:03 -07:00
parent 68e2cec638
commit 58fc3a3025
3 changed files with 214 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/lisp/drawl.pla
View File

@ -93,7 +93,7 @@ def natv_prog(symptr, expr)
if prog_car=>car == sym_cond // Inline cond() evaluation if prog_car=>car == sym_cond // Inline cond() evaluation
cond_expr = prog_car=>cdr cond_expr = prog_car=>cdr
while cond_expr while cond_expr
if eval_expr(cond_expr=>car=>car) == pred_true if eval_expr(cond_expr=>car=>car)
eval_expr(cond_expr=>car=>cdr=>car) // Drop result eval_expr(cond_expr=>car=>cdr=>car) // Drop result
break break
fin fin

11
src/lisp/loop.lisp
View File

@ -4,8 +4,17 @@
(T,(EQ I M))) (T,(EQ I M)))
)) ))
(LPRINT (LAMBDA (N) (LPRINT (LAMBDA (N)
(ATOM (PRINT N)) (PRINT N)
)) ))
) )
(PRINTLN 'TAIL)
(LOOP 1 100 LPRINT) (LOOP 1 100 LPRINT)
(PRINTLN 'FOR)
(FOR I 1 1 (< I 100) (PRINT I))
(PRINTLN 'WHILE)
(SETQ N 0)
(WHILE (< N 100) (PRINT N) (SETQ N (+ N 1)))
(PRINTLN 'UNTIL)
(SETQ N 1)
(UNTIL (> N 99) (PRINT N) (SETQ N (+ N 1)))

298
src/lisp/s-expr.pla
View File

@ -13,6 +13,7 @@ const NUM_TYPE = $30
const NUM_INT = $31 const NUM_INT = $31
const NUM_FLOAT = $32 const NUM_FLOAT = $32
const ARRAY_TYPE = $40 const ARRAY_TYPE = $40
const FUNC_TYPE = $50
const MARK_BIT = $80 const MARK_BIT = $80
const MARK_MASK = $7F const MARK_MASK = $7F
const NULL_HACK = 1 // Hack so we can set elements to NULL const NULL_HACK = 1 // Hack so we can set elements to NULL
@ -26,14 +27,21 @@ struc t_cons
word car word car
word cdr word cdr
end end
struc t_sym struc t_func
res[t_elem] res[t_elem]
word natv word natv
word lambda word lambda
end
struc t_sym
res[t_func]
word array word array
word apval word apval
char name[0] char name[0]
end end
struc t_funcenv
res[t_func]
word environ
end
struc t_numint struc t_numint
res[t_elem] res[t_elem]
word intval[2] word intval[2]
@ -54,20 +62,17 @@ const fmt_fp = FPSTR_FIXED|FPSTR_STRIP|FPSTR_FLEX
export var fmt_fpint = 6 export var fmt_fpint = 6
export var fmt_fpfrac = 4 export var fmt_fpfrac = 4
var assoc_list = NULL // SYM->value association list var assoc_list = NULL // Local SYM->value association list
var cons_list = NULL var global_list = NULL // Global SYM->value association list
var cons_free = NULL var cons_list = NULL
var int_list = NULL var cons_free = NULL
var int_free = NULL var int_list = NULL
var float_list = NULL var int_free = NULL
var float_free = NULL var float_list = NULL
var sym_list = NULL var float_free = NULL
var build_list = NULL var func_list = NULL
var eval_last = NULL var func_free = NULL
var sym_list = NULL
const MAX_PARAMS = 64
var param_vals[MAX_PARAMS] // In-flight evaluated argument values
var param_cnt
var sym_nil, sym_quote, sym_lambda, sym_set var sym_nil, sym_quote, sym_lambda, sym_set
var sym_cond, sym_if, sym_for, sym_space, sym_cr var sym_cond, sym_if, sym_for, sym_space, sym_cr
@ -79,6 +84,12 @@ predef eval_expr(expr)#1
// Garbage collector // Garbage collector
// //
const SWEEPSTACK_MAX = 64
byte sweep_stack_top = 0
var sweep_stack[SWEEPSTACK_MAX] // In-flight expressions
var eval_last = NULL
const GC_TRIGGER = 50 const GC_TRIGGER = 50
byte gc_pull = 0 byte gc_pull = 0
@ -93,6 +104,7 @@ def mark_elems#0
mark_list(cons_list) mark_list(cons_list)
mark_list(int_list) mark_list(int_list)
mark_list(float_list) mark_list(float_list)
mark_list(func_list)
end end
def sweep_expr(expr)#0 def sweep_expr(expr)#0
@ -111,8 +123,8 @@ end
def sweep_used#0 def sweep_used#0
var symptr, i, memptr, size var symptr, i, memptr, size
sweep_expr(global_list)
sweep_expr(assoc_list) sweep_expr(assoc_list)
sweep_expr(build_list)
sweep_expr(eval_last) sweep_expr(eval_last)
symptr = sym_list symptr = sym_list
while symptr while symptr
@ -132,16 +144,35 @@ def sweep_used#0
fin fin
symptr = symptr=>link symptr = symptr=>link
loop loop
if param_cnt if sweep_stack_top
// //
// Sweep in-flight lambda argument parameters // Sweep in-flight parameters
// //
for i = 0 to param_cnt - 1 for i = 0 to sweep_stack_top - 1
sweep_expr(param_vals[i]) sweep_expr(sweep_stack[i])
next next
fin fin
end end
def push_sweep_stack(expr)
if sweep_stack_top == SWEEPSTACK_MAX - 1
puts("Sweep stack overflow\n")
return NULL
fin
sweep_stack[sweep_stack_top] = expr
sweep_stack_top++
return expr
end
def pop_sweep_stack
if sweep_stack_top == 0
puts("Sweep stack underflow\n")
return NULL
fin
sweep_stack_top--
return sweep_stack[sweep_stack_top]
end
def collect_list(listhead, freehead)#2 def collect_list(listhead, freehead)#2
var elemptr, prevptr var elemptr, prevptr
@ -174,6 +205,7 @@ def collect_unused#0
cons_list, cons_free = collect_list(cons_list, cons_free) cons_list, cons_free = collect_list(cons_list, cons_free)
int_list, int_free = collect_list(int_list, int_free) int_list, int_free = collect_list(int_list, int_free)
float_list, float_free = collect_list(float_list, float_free) float_list, float_free = collect_list(float_list, float_free)
func_list, func_free = collect_list(func_list, func_free)
end end
export def gc#0 export def gc#0
@ -240,6 +272,25 @@ export def new_float(extptr)#1
return floatptr return floatptr
end end
def new_func
var funcptr
if func_free
funcptr = func_free
func_free = func_free=>link
else
gc_pull++
funcptr = heapalloc(t_func)
fin
funcptr=>link = func_list
func_list = funcptr
funcptr->type = FUNC_TYPE
funcptr=>natv = NULL
funcptr=>lambda = NULL
funcptr=>environ = NULL
return funcptr
end
def new_array(dim0, dim1, dim2, dim3) def new_array(dim0, dim1, dim2, dim3)
var ofst0, ofst1, ofst2, ofst3 var ofst0, ofst1, ofst2, ofst3
var size, aptr, memptr var size, aptr, memptr
@ -388,6 +439,14 @@ def print_atom(atom)#0
next next
puts("]\n") puts("]\n")
break break
is FUNC_TYPE
puts("FUNCTION:\n")
if atom=>natv; puts("NATV")
elsif atom=>lambda; print_expr(atom=>lambda)
else puts("???")
fin
puts("\nENVIRON:\n"); print_expr(atom=>environ); putln
break
otherwise otherwise
puts("Unknown atom type: $"); putb(atom->type); putln puts("Unknown atom type: $"); putb(atom->type); putln
wend wend
@ -603,16 +662,16 @@ export def new_assoc(symptr, valptr)#0
pair = new_cons pair = new_cons
pair=>car = symptr pair=>car = symptr
pair=>cdr = valptr pair=>cdr = valptr
if assoc_list // Add to end of assoc_list if global_list // Add to end of global_list
addlist = assoc_list addlist = global_list
while addlist=>cdr while addlist=>cdr
addlist = addlist=>cdr addlist = addlist=>cdr
loop loop
addlist=>cdr = new_cons addlist=>cdr = new_cons
addlist = addlist=>cdr addlist = addlist=>cdr
else // New list else // New list
assoc_list = new_cons global_list = new_cons
addlist = assoc_list addlist = global_list
fin fin
addlist=>car = pair addlist=>car = pair
end end
@ -621,7 +680,7 @@ def assoc_pair(symptr)
var pair var pair
// //
// Search association list for symbol // Search local association list for symbol
// //
pair = assoc_list pair = assoc_list
while pair while pair
@ -630,6 +689,16 @@ def assoc_pair(symptr)
fin fin
pair = pair=>cdr pair = pair=>cdr
loop loop
//
// Search global association list for symbol
//
pair = global_list
while pair
if (pair=>car=>car == symptr)
return pair=>car
fin
pair = pair=>cdr
loop
return NULL // SYM not associated return NULL // SYM not associated
end end
@ -641,9 +710,9 @@ export def set_assoc(symptr, valptr)#0
// //
pair = assoc_pair(symptr) pair = assoc_pair(symptr)
if pair if pair
pair=>cdr = valptr // update association pair=>cdr = valptr // Update association
else else
new_assoc(symptr, valptr) // add association if unknown new_assoc(symptr, valptr) // Add global association if unknown
fin fin
end end
@ -651,7 +720,7 @@ def assoc(symptr)
var pair var pair
// //
// Search association list for symbol // Search local association list for symbol
// //
pair = assoc_list pair = assoc_list
while pair while pair
@ -660,6 +729,16 @@ def assoc(symptr)
fin fin
pair = pair=>cdr pair = pair=>cdr
loop loop
//
// Search global association list for symbol
//
pair = global_list
while pair
if (pair=>car=>car == symptr)
return pair=>car=>cdr
fin
pair = pair=>cdr
loop
return NULL // SYM not associated return NULL // SYM not associated
end end
@ -668,7 +747,7 @@ end
// //
def enter_lambda(curl, expr, params)#2 // curl, expr def enter_lambda(curl, expr, params)#2 // curl, expr
var args, arglist, pairlist, parambase, i var args, arglist, pairlist, parambase
if !expr or expr=>car <> sym_lambda if !expr or expr=>car <> sym_lambda
puts("Invalid LAMBDA expression: "); print_expr(expr); putln puts("Invalid LAMBDA expression: "); print_expr(expr); putln
@ -676,33 +755,32 @@ def enter_lambda(curl, expr, params)#2 // curl, expr
fin fin
// //
// Evaluate the parameters // Evaluate the parameters
// - manipulate sweep_stack directly for performance
// //
parambase = param_cnt parambase = sweep_stack_top
while params while params
param_vals[param_cnt] = eval_expr(params=>car) sweep_stack[sweep_stack_top] = eval_expr(params=>car)
params = params=>cdr sweep_stack_top++
param_cnt++ if sweep_stack_top >= SWEEPSTACK_MAX
if param_cnt > MAX_PARAMS
puts("Parameter overflow:"); print_expr(expr); putln puts("Parameter overflow:"); print_expr(expr); putln
break return NULL, NULL
fin fin
params = params=>cdr
loop loop
args = expr=>cdr=>car args = expr=>cdr=>car
i = parambase sweep_stack_top = parambase
if curl == expr if curl == expr
//puts("Tail: "); print_expr(expr); putln
// //
// Set associations // Set associations
// //
arglist = assoc_list arglist = assoc_list
while args while args
arglist=>car=>cdr = param_vals[i] arglist=>car=>cdr = sweep_stack[parambase]
arglist = arglist=>cdr arglist = arglist=>cdr
args = args=>cdr args = args=>cdr
i++ parambase++
loop loop
else else
//puts("Enter: "); print_expr(expr); putln
// //
// Build arg list before prepending to assoc_list // Build arg list before prepending to assoc_list
// //
@ -720,17 +798,15 @@ def enter_lambda(curl, expr, params)#2 // curl, expr
fin fin
pairlist=>car = new_cons pairlist=>car = new_cons
pairlist=>car=>car = args=>car pairlist=>car=>car = args=>car
pairlist=>car=>cdr = param_vals[i] pairlist=>car=>cdr = sweep_stack[parambase]
args = args=>cdr args = args=>cdr
i++ parambase++
loop loop
if arglist if arglist
pairlist=>cdr = assoc_list pairlist=>cdr = assoc_list
assoc_list = arglist assoc_list = arglist
fin fin
fin fin
param_cnt = parambase
//print_expr(assoc_list); putln; getc
return expr, expr=>cdr=>cdr=>car return expr, expr=>cdr=>cdr=>car
end end
@ -755,7 +831,7 @@ export def eval_expr(expr)#1
elsif expr_car == sym_cond // Inline cond() evaluation elsif expr_car == sym_cond // Inline cond() evaluation
expr = expr=>cdr expr = expr=>cdr
while expr while expr
if eval_expr(expr=>car=>car) == @pred_true if eval_expr(expr=>car=>car)
expr = expr=>car=>cdr=>car expr = expr=>car=>cdr=>car
break break
fin fin
@ -763,7 +839,7 @@ export def eval_expr(expr)#1
loop loop
elsif expr_car == sym_if // Inline if() evaluation elsif expr_car == sym_if // Inline if() evaluation
expr = expr=>cdr expr = expr=>cdr
if eval_expr(expr=>car) == @pred_true if eval_expr(expr=>car)
expr = expr=>cdr=>car // THEN clause expr = expr=>cdr=>car // THEN clause
else else
expr = expr=>cdr=>cdr expr = expr=>cdr=>cdr
@ -859,57 +935,40 @@ def natv_eq(symptr, expr)
end end
def natv_and(symptr, expr) def natv_and(symptr, expr)
while expr and eval_expr(expr=>car) == @pred_true while expr and eval_expr(expr=>car)
expr = expr=>cdr expr = expr=>cdr
loop loop
return bool_pred(!expr) return bool_pred(!expr)
end end
def natv_or(symptr, expr) def natv_or(symptr, expr)
while expr and eval_expr(expr=>car) == NULL while expr and !eval_expr(expr=>car)
expr = expr=>cdr expr = expr=>cdr
loop loop
return bool_pred(expr) return bool_pred(expr)
end end
def natv_cons(symptr, expr) def natv_cons(symptr, expr)
symptr = new_cons symptr = push_sweep_stack(new_cons)
symptr=>cdr = build_list // Don't let this cons get freed up in GC
build_list = symptr
symptr=>car = eval_expr(expr=>car) symptr=>car = eval_expr(expr=>car)
expr = eval_expr(expr=>cdr=>car) symptr=>cdr = eval_expr(expr=>cdr=>car)
build_list = symptr=>cdr return pop_sweep_stack
symptr=>cdr = expr
return symptr
end end
def natv_list(symptr, expr) def natv_list(symptr, expr)
var list, lastbuild if expr
symptr = push_sweep_stack(new_cons)
lastbuild = build_list repeat
if build_list symptr=>car = eval_expr(expr=>car)
while lastbuild=>cdr expr = expr=>cdr
lastbuild = lastbuild=>cdr if expr
loop symptr=>cdr = new_cons
symptr = lastbuild symptr = symptr=>cdr
else fin
build_list = new_cons until !expr
symptr = build_list return pop_sweep_stack
fin fin
list = NULL return NULL
while expr
symptr=>cdr = new_cons
symptr = symptr=>cdr
if !list; list = symptr; fin
symptr=>car = eval_expr(expr=>car)
expr = expr=>cdr
loop
if lastbuild
lastbuild=>cdr = NULL // Cut new list off of build_list
else
build_list = NULL // No previous build_list
fin
return list
end end
def natv_car(symptr, expr) def natv_car(symptr, expr)
@ -1031,30 +1090,29 @@ def natv_cset(symptr, expr)
puts("CSET: Not a SYM\n") puts("CSET: Not a SYM\n")
return NULL return NULL
fin fin
expr = eval_expr(expr=>cdr=>car) symptr=>apval = eval_expr(expr=>cdr=>car) ^ NULL_HACK
symptr=>apval = expr ^ NULL_HACK
return symptr return symptr
end end
def natv_csetq(symptr, expr) def natv_csetq(symptr, expr)
symptr = expr=>car
if symptr->type & TYPE_MASK <> SYM_TYPE if symptr->type & TYPE_MASK <> SYM_TYPE
puts("CSETQ: Not a SYM\n") puts("CSETQ: Not a SYM\n")
return NULL return NULL
fin fin
symptr = eval_expr(expr=>cdr=>car) symptr=>apval = eval_expr(expr=>cdr=>car) ^ NULL_HACK
expr=>car=>apval = symptr ^ NULL_HACK
return symptr return symptr
end end
def natv_set(symptr, expr) def natv_set(symptr, expr)
symptr = eval_expr(expr=>cdr=>car) symptr = eval_expr(expr=>car)
set_assoc(eval_expr(expr=>car), symptr) set_assoc(symptr, eval_expr(expr=>cdr=>car))
return symptr return symptr
end end
def natv_setq(symptr, expr) def natv_setq(symptr, expr)
symptr = eval_expr(expr=>cdr=>car) symptr = expr=>car
set_assoc(expr=>car, symptr) set_assoc(symptr, eval_expr(expr=>cdr=>car))
return symptr return symptr
end end
@ -1082,8 +1140,9 @@ def natv_println(symptr, expr)
putln putln
return expr return expr
end end
def natv_for(symptr, expr) def natv_for(symptr, expr)
var index, ufunc, dlist, result var index, ufunc, dlist
var[2] incval, stepval var[2] incval, stepval
index = expr=>car index = expr=>car
@ -1109,23 +1168,70 @@ def natv_for(symptr, expr)
fin fin
stepval[0] = symptr=>intval[0] stepval[0] = symptr=>intval[0]
stepval[1] = symptr=>intval[1] stepval[1] = symptr=>intval[1]
ufunc = expr=>car ufunc = expr=>car
expr = expr=>cdr dlist = expr=>cdr
dlist = expr
// //
// Enter loop // Enter loop
// //
push_sweep_stack(NULL)
while eval_expr(ufunc) while eval_expr(ufunc)
expr = dlist expr = dlist
while expr while expr
result = eval_expr(expr=>car) //
expr = expr=>cdr // Keep result from getting GC'ed
//
sweep_stack[sweep_stack_top - 1] = eval_expr(expr=>car)
expr = expr=>cdr
loop loop
load32((index=>apval ^ NULL_HACK) + intval) load32((index=>apval ^ NULL_HACK) + intval)
add32(@stepval) add32(@stepval)
store32((index=>apval ^ NULL_HACK) + intval) store32((index=>apval ^ NULL_HACK) + intval)
loop loop
return result return pop_sweep_stack
end
def natv_while(symptr, expr)
var ufunc, dlist
ufunc = expr=>car
dlist = expr=>cdr
//
// Enter loop
//
push_sweep_stack(NULL)
while eval_expr(ufunc)
expr = dlist
while expr
//
// Keep result from getting GC'ed
//
sweep_stack[sweep_stack_top - 1] = eval_expr(expr=>car)
expr = expr=>cdr
loop
loop
return pop_sweep_stack
end
def natv_until(symptr, expr)
var ufunc, dlist
ufunc = expr=>car
dlist = expr=>cdr
//
// Enter loop
//
push_sweep_stack(NULL)
repeat
expr = dlist
while expr
//
// Keep result from getting GC'ed
//
sweep_stack[sweep_stack_top - 1] = eval_expr(expr=>car)
expr = expr=>cdr
loop
until eval_expr(ufunc)
return pop_sweep_stack
end end
// //
@ -1164,5 +1270,7 @@ new_sym("SETQ")=>natv = @natv_setq
new_sym("PRINT")=>natv = @natv_print new_sym("PRINT")=>natv = @natv_print
new_sym("PRINTLN")=>natv = @natv_println new_sym("PRINTLN")=>natv = @natv_println
new_sym("FOR")=>natv = @natv_for new_sym("FOR")=>natv = @natv_for
new_sym("WHILE")=>natv = @natv_while
new_sym("UNTIL")=>natv = @natv_until
return modkeep | modinitkeep return modkeep | modinitkeep
done done