mirror of
https://github.com/samsonjs/sectorlisp.git
synced 2026-03-25 09:05:48 +00:00
5a33a6b97a
This GC wraps Eval() to create a copy of the result, and then memcpy's it backwards to the position where the g_mem pointer resided at the beginning of Eval() thereby discarding all the cons cells that got created which weren't part of the result. Overlap (or negative GC) isn't possible because we don't copy cells beneath the low water mark. As it turns out 44 bytes is all you need to implement garbage collection when your language guarantees that data structures can't have cycles, due to the lack of mutability.
329 lines
8.1 KiB
ArmAsm
329 lines
8.1 KiB
ArmAsm
/*-*- mode:unix-assembly; indent-tabs-mode:t; tab-width:8; coding:utf-8 -*-│
|
|
│vi: set et ft=asm ts=8 tw=8 fenc=utf-8 :vi│
|
|
╞══════════════════════════════════════════════════════════════════════════════╡
|
|
│ Copyright 2020 Justine Alexandra Roberts Tunney │
|
|
│ Copyright 2021 Alain Greppin │
|
|
│ Some size optimisations by Peter Ferrie │
|
|
│ │
|
|
│ Permission to use, copy, modify, and/or distribute this software for │
|
|
│ any purpose with or without fee is hereby granted, provided that the │
|
|
│ above copyright notice and this permission notice appear in all copies. │
|
|
│ │
|
|
│ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL │
|
|
│ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED │
|
|
│ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE │
|
|
│ AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL │
|
|
│ DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR │
|
|
│ PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER │
|
|
│ TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR │
|
|
│ PERFORMANCE OF THIS SOFTWARE. │
|
|
╚─────────────────────────────────────────────────────────────────────────────*/
|
|
|
|
// LISP meta-circular evaluator in a MBR
|
|
// Compatible with the original hardware
|
|
|
|
.set g_mem, %cx
|
|
.set g_token, %cx
|
|
.set ZERO, %bh
|
|
.set TWO, %bx
|
|
|
|
.section .text,"ax",@progbits
|
|
.type kNil,@object
|
|
.type kT,@object
|
|
.type kQuote,@object
|
|
.type kCond,@object
|
|
.type kAtom,@object
|
|
.type kCar,@object
|
|
.type kCdr,@object
|
|
.type kCons,@object
|
|
.type kEq,@object
|
|
.type start,@function
|
|
.type begin,@function
|
|
.globl _start
|
|
.code16
|
|
|
|
_start:
|
|
kNil: .asciz "NIL" # dec %si ; dec %cx ; dec %sp
|
|
kT: .asciz "T" # add %dl,(%si) boot A:\ DL=0
|
|
start: ljmp $0x7c00>>4,$begin # cs = 0x7c00 is boot address
|
|
.asciz ""
|
|
kQuote: .asciz "QUOTE"
|
|
kCond: .asciz "COND"
|
|
kAtom: .asciz "ATOM" # ordering matters
|
|
kCar: .asciz "CAR" # ordering matters
|
|
kCdr: .asciz "CDR" # ordering matters
|
|
kCons: .asciz "CONS" # ordering matters
|
|
kEq: .asciz "EQ" # needs to be last
|
|
|
|
begin: xor %ax,%ax
|
|
push %cs # memory model ds=es=ss=cs
|
|
pop %ds
|
|
push %cs
|
|
pop %es
|
|
push %cs
|
|
cli # disable interrupts
|
|
pop %ss # disable nonmaskable interrupts
|
|
mov %ax,%sp # use null pointer as our stack
|
|
sti # enable interrupts
|
|
cld # direction forward
|
|
mov $2,TWO
|
|
main: mov $'\n',%dl
|
|
mov $0x8000,g_mem
|
|
call GetToken
|
|
call GetObject
|
|
xor %dx,%dx
|
|
call Eval
|
|
xchg %ax,%di
|
|
call PrintObject
|
|
mov $'\r',%al
|
|
call PutChar
|
|
jmp main
|
|
|
|
GetToken: # GetToken():al, dl is g_look
|
|
mov g_token,%di
|
|
mov %di,%si
|
|
1: mov %dl,%al
|
|
cmp $' ',%al
|
|
jbe 2f
|
|
stosb
|
|
xchg %ax,%si
|
|
2: call GetChar
|
|
xchg %ax,%dx # dl = g_look
|
|
cmp $' ',%al
|
|
jbe 1b
|
|
cmp $')',%al
|
|
jbe 3f
|
|
cmp $')',%dl
|
|
ja 1b
|
|
3: movb ZERO,(%di)
|
|
xchg %si,%ax
|
|
ret
|
|
|
|
.PutObject: # .PutObject(c:al,x:di)
|
|
call PutChar # preserves di
|
|
PrintObject: # PrintObject(x:di)
|
|
test %di,%di # set sf=1 if cons
|
|
js .PrintList # jump if cons
|
|
.PrintAtom:
|
|
mov %di,%si # lea g_str(%di),%si
|
|
.PrintString: # nul-terminated in si
|
|
lodsb
|
|
test %al,%al # test for nul terminator
|
|
jz .ret # -> ret
|
|
call PutChar
|
|
jmp .PrintString
|
|
.PrintList:
|
|
mov $'(',%al
|
|
2: push (TWO,%di) # save 1 Cdr(x)
|
|
mov (%di),%di # di = Car(x)
|
|
call .PutObject
|
|
pop %ax # restore 1
|
|
test %ax,%ax
|
|
jz 4f # jump if nil
|
|
xchg %ax,%di
|
|
mov $' ',%al
|
|
js 2b # jump if cons
|
|
mov $249,%al # bullet (A∙B)
|
|
call .PutObject
|
|
4: mov $')',%al
|
|
jmp PutChar
|
|
|
|
GetObject: # called just after GetToken
|
|
cmpb $'(',%al
|
|
je GetList
|
|
.Intern:
|
|
xor %di,%di # di = g_str
|
|
xor %al,%al
|
|
0: push %di # save 1
|
|
1: cmpsb
|
|
jne 2f
|
|
dec %di
|
|
scasb
|
|
jne 1b
|
|
jmp 5f
|
|
2: pop %si # drop 1
|
|
mov g_token,%si
|
|
3: scasb
|
|
jne 3b
|
|
cmp (%di),%al
|
|
jne 0b
|
|
push %di # StpCpy
|
|
4: movsb
|
|
dec %di
|
|
scasb
|
|
jnz 4b
|
|
5: pop %ax # restore 1
|
|
.ret: ret
|
|
|
|
GetChar:
|
|
xor %ax,%ax # get keystroke
|
|
int $0x16 # keyboard service
|
|
# ah is bios scancode
|
|
# al is ascii character
|
|
PutChar:
|
|
mov $0x0e,%ah # teletype output al cp437
|
|
int $0x10 # vidya service
|
|
cmp $'\r',%al # don't clobber
|
|
jne .ret
|
|
mov $'\n',%al
|
|
jmp PutChar
|
|
|
|
////////////////////////////////////////////////////////////////////////////////
|
|
|
|
Pairlis:test %di,%di # Pairlis(x:di,y:si,a:dx):ax
|
|
jz 1f # jump if nil
|
|
push (TWO,%di) # save 1 Cdr(x)
|
|
lodsw
|
|
push (%si) # save 2 Cdr(y)
|
|
mov (%di),%di
|
|
call Cons # preserves dx
|
|
pop %si # restore 2
|
|
pop %di # restore 1
|
|
push %ax # save 3
|
|
call Pairlis
|
|
jmp xCons # can be inlined here
|
|
1: xchg %dx,%ax
|
|
ret
|
|
|
|
Evlis: test %di,%di # Evlis(m:di,a:dx):ax
|
|
jz 1f # jump if nil
|
|
push (TWO,%di) # save 1 Cdr(m)
|
|
mov (%di),%ax
|
|
call Eval
|
|
pop %di # restore 1
|
|
push %ax # save 2
|
|
call Evlis
|
|
|
|
xCons: pop %di # restore 2
|
|
Cons: xchg %ax,%si # Cons(m:di,a:ax):ax
|
|
xchg %di,%ax
|
|
mov g_mem,%di
|
|
stosw
|
|
xchg %si,%ax
|
|
stosw
|
|
xchg %di,g_mem
|
|
1: xchg %di,%ax
|
|
ret
|
|
|
|
Gc: cmp %dx,%di # Gc(x:di,mark:dx,aj:bp):ax
|
|
jb 1b # we assume immutable cells
|
|
push (TWO,%di) # mark prevents negative gc
|
|
mov (%di),%di
|
|
call Gc
|
|
pop %di
|
|
push %ax
|
|
call Gc
|
|
pop %di
|
|
call Cons
|
|
sub %bp,%ax # subtract adjustment
|
|
ret
|
|
|
|
GetList:call GetToken
|
|
cmpb $')',%al
|
|
je .retF
|
|
call GetObject
|
|
push %ax # save 1
|
|
call GetList
|
|
jmp xCons
|
|
|
|
.Eval: test %ax,%ax # Eval(e:ax,a:dx):ax w/o gc
|
|
jns Assoc # lookup val if atom
|
|
xchg %ax,%si # di = e
|
|
lodsw # ax = Car(e)
|
|
cmp $kQuote,%ax # maybe CONS
|
|
mov (%si),%di # di = Cdr(e)
|
|
je Car
|
|
cmp $kCond,%ax
|
|
je Evcon
|
|
.Ldflt2:push %ax # save 2
|
|
call Evlis # preserves dx
|
|
xchg %ax,%si
|
|
pop %ax # restore 2
|
|
# jmp Apply
|
|
|
|
Apply: test %ax,%ax # Apply(fn:ax,x:si:a:dx):ax
|
|
jns .switch # jump if atom
|
|
xchg %ax,%di # di = fn
|
|
.lambda:mov (TWO,%di),%di # di = Cdr(fn)
|
|
push %di # save 1
|
|
mov (%di),%di # di = Cadr(fn)
|
|
call Pairlis
|
|
xchg %ax,%dx
|
|
pop %di # restore 1
|
|
jmp .EvCadr
|
|
.ifCons:cmp $kCons,%al
|
|
mov (TWO,%si),%si # si = Cdr(x)
|
|
lodsw # si = Cadr(x)
|
|
je Cons
|
|
.isEq: cmp %di,%ax # we know for certain it's eq
|
|
jne .retF
|
|
.retT: mov $kT,%ax
|
|
ret
|
|
.switch:cmp $kEq,%ax # eq is last builtin atom
|
|
ja .dflt1 # ah is zero if not above
|
|
mov (%si),%di # di = Car(x)
|
|
.ifCar: cmp $kCar,%al
|
|
je Car
|
|
.ifCdr: cmp $kCdr,%al
|
|
je Cdr
|
|
.ifAtom:cmp $kAtom,%al
|
|
jne .ifCons
|
|
test %di,%di # test if atom
|
|
jns .retT
|
|
.retF: xor %ax,%ax # ax = nil
|
|
ret
|
|
.dflt1: push %si # save x
|
|
call Eval
|
|
pop %si # restore x
|
|
jmp Apply
|
|
|
|
Cadr: mov (TWO,%di),%di # contents of decrement register
|
|
.byte 0x3C # cmp §scasw,%al (nop next byte)
|
|
Cdr: scasw # increments our data index by 2
|
|
Car: mov (%di),%ax # contents of address register!!
|
|
ret
|
|
|
|
.Assoc: mov (TWO,%si),%dx # dx = Cdr(y)
|
|
Assoc: mov %dx,%si # Assoc(x:ax,y:dx):ax
|
|
test %dx,%dx # nil test
|
|
jz .retF
|
|
mov (%si),%di # bx = Car(y)
|
|
cmp %ax,(%di) # (%di) = Caar(y)
|
|
jne .Assoc
|
|
mov (TWO,%di),%ax # ax = Cdar(y)
|
|
ret
|
|
|
|
1: mov (TWO,%di),%di # di = Cdr(c)
|
|
Evcon: push %di # save c
|
|
mov (%di),%si # di = Car(c)
|
|
lodsw # ax = Caar(c)
|
|
call Eval
|
|
pop %di # restore c
|
|
test %ax,%ax # nil test
|
|
jz 1b
|
|
mov (%di),%di # di = Car(c)
|
|
.EvCadr:call Cadr # ax = Cadar(c)
|
|
# jmp Eval
|
|
|
|
Eval: push %dx # Eval(e:ax,a:dx):ax w/ gc
|
|
push g_mem # with garbage collections
|
|
call .Eval # discards non-result cons
|
|
pop %dx
|
|
push g_mem
|
|
mov g_mem,%bp
|
|
sub %dx,%bp
|
|
xchg %ax,%di
|
|
call Gc
|
|
pop %si
|
|
mov %dx,%di
|
|
mov g_mem,%cx
|
|
sub %si,%cx
|
|
rep movsb
|
|
mov %di,g_mem
|
|
pop %dx
|
|
ret
|
|
|
|
.type .sig,@object
|
|
.sig:
|
|
.fill 510 - (. - _start), 1, 0xce
|
|
.word 0xAA55
|