Lisp-y
Data Abstraction
    in Forth
       🙜
   Brad Nelson
       🙜
December 19, 2020

Introduction
     🙜
 • Lisp pairs as a data abstraction
   • Closed means of combination
 • Building a GC in Forth
 • Mapping, Filtering, Aggregating
 • Binding and closures

Everything is a pair

(car (cons x y)) = x
(cdr (cons x y)) = y

(cons 1 2)
    =
  ( 1 . 2 )

(cons 1 (cons 2 (cons 3 nil)))
             =
          ( 1 2 3 )

+---+---+
| 1 | o |
+---+-|-+
      v
    +---+---+
    | 2 | o |
    +---+-|-+
          v
        +---+---+
        | 3 |NIL|
        +---+---+

(cons 1 (cons 2 3))
             =
          ( 1 2 . 3 )

((1 1) (2 4) (3 9) (4 16))

( x y )  pair  ( p )
  ( p ) unpair ( x y )

Garbage Collection
        🙜
 • Mark and Sweep
 • Stop and Copy
 • Hybrid & Generational
 • Boehm (Conservative)

Stop and Copy
      🙜
 • Cheney 1970
 • From/To Space
 • Repack live objects
 • Leave "broken-hearts"

Blackboard

Very Small

1000000 constant pair-count
: pairs ( n -- n ) 2* cells ;
pair-count pairs 2* allocate throw constant pair-heap
variable pair-brk   variable pair-base
pair-heap pair-base !
 🙜
: car ( p -- n ) @ ;        : car! ( n p -- ) ! ;
: cdr ( p -- n ) cell+ @ ;  : cdr! ( n p -- ) cell+ ! ;
 🙜
: pair+? ( p -- f )
  pair-heap - dup 0>= swap pair-count pairs 2* < and ;
: pair? ( p -- f )
  pair-base @ - dup 0>= swap pair-count pairs < and ;
: old? ( p -- f) dup pair+? swap pair? 0= and ;
 🙜
defer gc   create nil   : null? nil = ;
: full? ( -- f ) pair-brk @ pair-count >= ;
: reserve   full? if gc then ;
: pair-rel ( n -- p ) pairs pair-base @ + ;
: pair-allot ( -- p ) pair-brk @ pair-rel 1 pair-brk +! ;
: pair ( x y -- p )
  reserve pair-allot dup dup >r >r cdr! r> car! r> ;
: cons pair ;
: unpair ( p -- x y ) dup car swap cdr ;

: bind ( a xt -- p ) pair ;
: invoke ( p/a -- ) begin dup pair? while unpair repeat execute ;
 🙜
: foreach' ( l op -- last )
  begin over pair? while dup >r >r unpair
    r> swap >r invoke r> r> repeat drop ;
: foreach ( l op -- ) foreach' null? 0= throw ;
 🙜
variable roots   nil roots !
: +root ( a -- ) roots @ pair roots ! ;
: root value lastxt >body +root ;
variable broken-heart
: relocate ( a -- )
  dup @ unpair pair over @ broken-heart over car! over swap cdr! swap ! ;
: conserve ( a -- )
  dup @ car broken-heart = if dup @ cdr swap ! else relocate then ;
: preserve ( a -- ) dup @ old? if conserve else drop then ;
: newfixup1 ( n -- ) dup pair-rel dup preserve cell+ preserve 1+ ;
: newfixup 0 begin dup pair-brk @ < while newfixup1 repeat drop ;
 🙜
: rpwalk rp@ rp0 @ swap - cell / 0 ?do rp@ i cells + preserve loop ;
: spwalk depth 0 ?do sp@ i cells + preserve loop ;
: rootwalk roots preserve roots @ ['] preserve foreach ;
: newspace   0 pair-brk !   pair-base @ pair-heap =
  if pair-heap pair-count pairs + else pair-heap then pair-base ! ;
: collect   newspace rpwalk spwalk rootwalk newfixup
            full? if abort" heap full" then ;
' collect is gc   : used pair-brk @ ;

Allocation

1000000 constant pair-count
: pairs ( n -- n ) 2* cells ;
pair-count pairs 2* allocate
  throw constant pair-heap
variable pair-brk   variable pair-base
pair-heap pair-base !

: car ( p -- n ) @ ;
: cdr ( p -- n ) cell+ @ ;

: car! ( n p -- ) ! ;
: cdr! ( n p -- ) cell+ ! ;

: pair+? ( p -- f )
  pair-heap - dup 0>= swap pair-count pairs 2* < and ;
: pair? ( p -- f )
  pair-base @ - dup 0>= swap pair-count pairs < and ;
: old? ( p -- f) dup pair+? swap pair? 0= and ;

Collection

defer gc   create nil   : null? nil = ;
: full? ( -- f ) pair-brk @ pair-count >= ;
: reserve   full? if gc then ;

: pair-rel ( n -- p )
  pairs pair-base @ + ;
: pair-allot ( -- p )
  pair-brk @ pair-rel 1 pair-brk +! ;

: pair ( x y -- p )
  reserve pair-allot
  dup dup >r >r cdr! r> car! r> ;
: cons pair ;
: unpair ( p -- x y ) dup car swap cdr ;

variable roots   nil roots !
: +root ( a -- ) roots @ pair roots ! ;
: root value lastxt >body +root ;

nil root foo
my-list to foo

variable broken-heart
: relocate ( a -- )
  dup @ unpair pair over @
  broken-heart over car! over swap cdr! swap ! ;
: conserve ( a -- )
  dup @ car broken-heart =
  if dup @ cdr swap ! else relocate then ;
: preserve ( a -- )
  dup @ old? if conserve else drop then ;
: newfixup1 ( n -- )
  dup pair-rel dup preserve cell+ preserve 1+ ;
: newfixup 0 begin dup pair-brk @ <
    while newfixup1 repeat drop ;

: rpwalk rp@ rp0 @ swap - cell / 0
  ?do rp@ i cells + preserve loop ;
: spwalk depth 0 ?do sp@ i cells + preserve loop ;
: rootwalk roots preserve roots @ ['] preserve foreach ;

: newspace
  0 pair-brk !
  pair-base @ pair-heap = if
    pair-heap pair-count pairs +
  else
    pair-heap
  then pair-base ! ;

: collect
  newspace
  rpwalk
  spwalk
  rootwalk
  newfixup
  full? if abort" heap full" then ;
' collect is gc   : used pair-brk @ ;

Parsing
  and
Printing

: l. recursive dup pair? if
    ." ( " ['] l. foreach'
    dup null? if drop else ." . " l. then
    ." ) "
  else
    dup null? if ." nil " else . then
  then ;

: list1 ( .. b n -- p )
  0 ?do pair loop ;
: list ( .. n -- p )
  nil swap list1 ;

9 8 7   3 list l.
( 9 8 7 )

variable list-depth
variable is-dotted
: ?dot ( pxn n )
  is-dotted @ 0= if nil swap else 1- then ;
: ((   list-depth @ is-dotted @ 0 is-dotted !
       depth list-depth ! ;
: ))   depth list-depth @ - ?dot list1 >r
       is-dotted ! list-depth ! r> ;
: ..   -1 is-dotted ! ;

(( 1 2 3 .. 4 )) l.
  🙜
( 1 2 3 . 4 )

(( (( 1 1 )) (( 2 4 )) (( 3 9 )) )) l.
  🙜
( ( 1 1 ) ( 2 4 ) ( 3 9 ) )

Lambdas / Closures
        🙜
 • Bind arguments to procedures
 • CREATE DOES> but dynamic

: multiplier ( n -- )
  create , does> @ * ;
3 multiplier thrice
4 thrice .
  🙜
7

: bind ( a xt -- p ) pair ;
: invoke ( p/a -- )
  begin dup pair? while
    unpair repeat execute ;

: multiplier ( n -- p )
  ['] * bind ;
4 3 multiplier invoke .
  🙜
7

a b c ' foo bind bind bind

: foreach' ( l op -- last )
  begin over pair? while
    dup >r >r unpair r> swap >r
    invoke r> r> repeat drop ;
: foreach ( l op -- )
  foreach' null? 0= throw ;

: sum ( l -- n )
  0 swap ['] + foreach ;

(( 1 2 3 )) sum .
  🙜
6

: chain1 ( a b -- )
  >r invoke r> invoke ;
: chain ( a b -- p )
  ['] chain1 bind bind ;

99 ' 1+ ' square chain invoke
  🙜
10000

99  2 ' * bind  1 ' + bind  chain invoke .
  🙜
199

: length ( l -- n )
  0 swap ['] drop ['] 1+ chain foreach ;
: average ( l -- n )
  dup sum swap length / ;

(( 1 2 3 )) length .
  🙜
3

(( 1 2 3 )) average .
  🙜
2

: ^pair swap pair ;
: reverse-append ( a b -- l )
  swap ['] ^pair foreach ;
: reverse ( l -- l' )
  nil reverse-append ;

(( 1 2 3 4 )) reverse l.
  🙜
( 4 3 2 1 )

: append ( a b -- l )
  >r reverse r> reverse-append ;

(( 1 2 3 )) (( 4 5 6 )) append l.
  🙜
( 1 2 3 4 5 6 )

: nilpair nil nil pair ;
: prepend! ( a p -- )
  dup >r car pair r> car! ;
: map1 ( a op p -- )
  >r invoke r> prepend! ;
: map ( l op -- l' )
  nilpair dup >r ['] map1 bind bind
  foreach r> car reverse ;

(( 1 2 3 4 5 )) ' square map l.
  🙜
( 1 4 9 16 25 )

: range ( a b -- p )
  1- nil -rot ?do i ^pair -1 +loop ;

0 10 range l.
  🙜
( 0 1 2 3 4 5 6 7 8 9 )

: filter1 ( a op p -- )
  >r over >r invoke r> r> rot
  if prepend! else 2drop then ;
: filter ( l op -- l' )
  nilpair dup >r ['] filter1 bind bind
  foreach r> car reverse ;

2 100 range ' prime? filter l.
  🙜
( 2 3 5 7 11 13 17 19 23 29 31
  37 41 43 47 53 59 61 67 71 73
  79 83 89 97 )

: l= ( a b -- f ) recursive dup pair? if
    2dup car swap car l=
    >r cdr swap cdr l= r> and
  else
     =
  then ;

CAVEATS
   🙤
 • Numbers in range of heap _unstable_
   • Fix with boxing in a pair or tagged integers
   • No hooks for resource freeing
 • Non-pairs, not freed
 • Concurrency & Performance

   What's up
with the slides?

PRESENTATION FORMAT
         🙤
 • Takahashi Method
   • Minimalistic presentation style
   • suckless →  sent →  websent
   • 200 LOC
 • Focus on content
   • Unicode text file as input
   • Show each paragraph fullscreen
   • @image.png for full page images

@stenoforth.png


trees
🌲🌲🌲🌲
 
evil
🙈🙉🙊
 
♤ spades
♥ hearts
♧ clubs
♦ diamonds

trees
🌲🌲🌲🌲

evil
🙈🙉🙊

♤ spades
♥ hearts
♧ clubs
♦ diamonds

QUESTIONS?
    ⚘
thank you!