StackLisp implementation of Pyramid runtime

gistfile1.txt

#lang sweet-exp stacklisp

provide
  rename-out void identity
  define-variable!
  set-variable-value!
  lookup-variable-value
  extend-environment
  tag
  rename-out allocate-words allocate
  rename-out read-memory-offset read-memory
  rename-out write-memory-offset write-memory
  false?
  rename-out + add
  make-fixnum
  fixnum-value
  rename-out fixnum-value symbol-value
  rename-out fixnum-value character-value
  save-continuation
  restore-continuation!
  continuation?
  make-compiled-procedure
  compiled-procedure-entry
  compiled-procedure-env
  compiled-procedure?
  primitive-procedure?
  apply-primitive-procedure
  singleton
  pair
  pair?
  left
  right
  null?
  null
  rename-out vector-read read-vector
  rename-out vector-write! write-vector

define TAG-FIXNUM 0
define TAG-SYMBOL 1
define TAG-COMPILED-PROCEDURE 2
define TAG-PRIMITIVE-PROCEDURE 3
define TAG-PAIR 4
define TAG-VECTOR 5
define TAG-NIL 6
define TAG-CONTINUATION 7
define TAG-FRAME 8
define TAG-ENVIRONMENT 9
define TAG-CHARACTER 10
define TAG-BYTES 11

define WORD 32

define MEM-ENV           #x00
define MEM-PROC          #x20
define MEM-CONTINUE      #x40
define MEM-ARGL          #x60
define MEM-VAL           #x80
define MEM-STACK-SIZE    #xa0
define MEM-NULL          #xc0
define MEM-ALLOCATOR     #xe0
define MEM-DYNAMIC-START #x100 ; This should be the highest hardcoded memory address.

define =() evm(EQ)
define +() evm(ADD)
define -() evm(SUB)
define *() evm(MUL)
define or() evm(OR)

define (or3 a b c) or(a or(b c))
define (+& ptr idx)
  + ptr *(idx WORD)

define entry(user-program)
  initialize-environment()
  program()
  return read-register(MEM-VAL)

define initialize-environment()
  write-address MEM-ALLOCATOR MEM-DYNAMIC-START
  write-address MEM-ENV make-empty-environment()
  write-address MEM-CONTINUE 31337
  write-address MEM-PROC 1337
  write-address MEM-ARGL 337
  write-address MEM-NULL TAG-NULL

define return(ptr)
  if {ptr > 2}
    return-unboxed ptr
    return-boxed tag(ptr) ptr

define return-unboxed(x)
  return-fixnum(make-fixnum(x))

define error(x)
  evm('REVERT)

define return-boxed(tag ptr)
  if {{tag = TAG-FIXNUM} or3
      {tag = TAG-CHARACTER} or3
      {tag = TAG-SYMBOL}}
    return-fixnum ptr
    if {tag = TAG-PAIR}
      return-list ptr
      if {tag = TAG-VECTOR}
        return-vector ptr
        if {tag = TAG-NULL}
          return-null
          if {tag = TAG-BYTES}
            return-bytes ptr
            error('return-invalid-type)


define return-fixnum(ptr)
  evm(RETURN)({ptr +& 1} WORD)

define return-list(ptr)
  return-vector list->vector(ptr)

define return-vector(ptr)
  vector-unbox! ptr
  evm(RETURN)(vector-data(ptr) *(vector-len(ptr) WORD))

define return-null() evm(STOP)
define return-bytes(ptr)
  evm(RETURN)(bytes-data(ptr) bytes-len(ptr))

define read-register read-memory

; Values

define tag read-memory

define make-fixnum(x) initialize2(TAG-FIXNUM x)
define fixnum-value(ptr) read-memory({ ptr +& 1 })

define list->vector(ptr)
  copy-list->memory! ptr make-vector(list-length(ptr))

define copy-list->memory!(list ptr)
  if null?(list)
    void()
    begin
      write-memory! left(list) ptr
      copy-list->memory! right(list) +(ptr WORD)

define vector-unbox!(vec)
  vector-map! vec fixnum-value

define vector-map!(vec f)
  memory-map! vector-data(vec) vector-len(vec) f

define memory-map!(ptr len f)
  if {len = 0}
    void()
    begin
      write-memory! ptr f(read-memory ptr)
      memory-map! {ptr +& 1} f

define bytes-data(ptr) { ptr +& 2 }
define bytes-len(ptr) { ptr +& 1 }

define read-memory() evm(MLOAD)

define write-memory() evm(MSTORE)

define void()

define allocate-words(n) allocate{ n * WORD }
define allocate(bytes-size)
  define ptr read-memory(MEM-ALLOCATOR)
  write-memory ptr {ptr + bytes-size}
  ptr

define initialize1(ptr a)
  define ptr allocate-words(1)
  write-memory ptr a
  ptr

define initialize2(ptr a b)
  define ptr allocate-words(2)
  write-memory ptr a
  write-memory {ptr +& 1} b
  ptr

define initialize3(ptr a b c)
  define ptr allocate-words(3)
  write-memory ptr a
  write-memory {ptr +& 1} b
  write-memory {ptr +& 2} c
  ptr

; Primitive Operations

define define-variable!(name value env)
  define frame environment-frame(env)
  define-variable-scan left(frame) right(frame) name value frame

define define-variable-scan(fvars fvals name value frame)
  if null?(fvars)
    add-binding-to-frame! name value frame
    if { left(fvars) = name }
      set-left! fvals value
      define-variable-scan right(fvars) right(fvals) name value frame

define environment-frame left

define set-variable-value-scan(fvars fvals name value env)
  if null?(fvars)
    set-variable-value! name value env
    if { left(fvars) = name }
      set-left! fvals value
      set-variable-value-scan left(fvars) left(fvals) name value env

define set-variable-value-env-loop(frame name value env)
  set-variable-value-scan left(frame) right(frame) name value env

define set-variable-value!(name value env)
  if null?(env)
    error('set-variable-value!-not-found)
    set-variable-value-env-loop left(env) name value right(env)

define lookup-variable-value-scan(fvars fvals name env)
  if null?(fvars)
    lookup-variable-value name right(env)
    if { left(fvars) = name }
      left fvals
      lookup-variable-value-scan right(fvars) right(fvals) name env

define lookup-variable-value(name env)
  if null?(env)
    error('lookup-variable-value-not-found)
    let* <* frame left(env) *>
      lookup-variable-value-scan left(frame) right(frame) name env

define make-frame(vars vals)
  initialize3 TAG-FRAME vars vals

define make-environment(frame rest)
  initialize3 TAG-ENVIRONMENT frame rest

define extend-environment(vars vals env)
  make-environment make-frame(vars vals) env

define false?() evm(ISZERO)

define save-continuation()
  pop-vector read-memory(MEM-STACK-SIZE)          ; [ vec ]
  allocate-words(4)                               ; [ ptr; vec ]
  write-memory! evm(DUP1) TAG-CONTINUATION
  write-memory! {evm(DUP1) +& 1} read-memory(MEM-CONTINUE)
  write-memory! {evm(DUP1) +& 2} read-memory(MEM-ENV)
  evm(DUP1)                                       ; [ ptr; ptr; vec ]
  evm(SWAP2)                                      ; [ vec; ptr; ptr ]
  evm(SWAP1)                                      ; [ ptr; vec; ptr ]
  write-memory! {void() +& 3} void()              ; [ ptr ]
  write-memory! MEM-STACK-SIZE void()             ; [ ]
  continuation-stack (read-memory MEM-STACK-SIZE) ; [ stack ]
  push-vector void()                              ; [ *STACK ]
  read-memory MEM-STACK-SIZE                      ; [ ptr ]
  evm(DUP1)                                       ; [ ptr; ptr ]
  continuation-stack-size void()                  ; [ size; ptr ]
  write-memory MEM-STACK-SIZE void()              ; [ ptr ]

define restore-continuation!()                              ; [ cont ]
  write-memory! MEM-ENV void()                              ; [ ]
  pop $ read-memory MEM-STACK-SIZE                          ; [ ERASED-STACK ]
  read-memory MEM-ENV                                       ; [ cont ]
  write-memory MEM-ENV      read-memory({ evm(DUP1) +& 2 }) ; [ cont ]
  write-memory MEM-CONTINUE read-memory({ evm(DUP1) +& 1 }) ; [ cont ]
  continuation-stack void()                                 ; [ stack-ptr ]
  write-memory MEM-STACK-SIZE vector-len(evm(DUP1))         ; [ stack-ptr ]
  push-vector void()                                        ; [ *STACK ]
  goto read-memory(MEM-CONTINUE)                            ; [ *STACK ]

define continuation?(cont) { tag(cont) = TAG-CONTINUATION }
define make-compiled-procedure(code env)
  initialize3 TAG-COMPILED-PROCEDURE code env

define compiled-procedure-entry(x)
  read-memory { x +& 1 }

define compiled-procedure-env
  read-memory { x +& 2 }

define compiled-procedure?(x) { tag(x) = TAG-COMPILED-PROCEDURE }

define primitive-procedure?(x) { tag(x) = TAG-PRIMITIVE-PROCEDURE }
define apply-primitive-procedure(proc argl) error('apply-primitive-procedure-unimplemented)
define singleton(x)
  pair x null
define pair(a b) initialize3(TAG-PAIR a b)
define pair?(x) { tag(x) = TAG-PAIR }
define left(x) read-memory{ x +& 1 }
define right(x) read-memory{ x +& 2 }
define set-left!(ptr x) write-memory({ ptr +& 1} x)
define set-right!(ptr x) write-memory({ ptr +& 2} x)
define null?(x) { x = MEM-NULL }
define null MEM-NULL

define vector-read(vec i) read-memory{ vec +& {i + 2}}
define vector-write!(vec i x) write-memory({ vec +& {i + 2}} x)