A compact SECD virtual machine implementation

Compiler.scm

;;;; S-expression to SECD instruction Compiler ;;;;
;;; 2012 Minori Yamashita <[email protected]> ;;add your name here
;;;
;;; reference:
;;;   http://www.geocities.jp/m_hiroi/func/abcscm33.html
;;;

(load "./SECD.scm")

;;; Helpers ;;;
(define (atom? x)
  (cond
    [(string?  x) #t]
    [(number?  x) #t]
    [(boolean? x) #t]
    [(char?    x) #t]
    [else #f]))

;;compile :: Lisp -> SECD
(define (compile program)
  (fold-right compile- `((,stop)) program))

;;compile- :: Lisp -> code -> code
(define (compile- exp code)
  ;(print (format "exp : ~S" exp))
  ;(print (format "code: ~S" code))
  (newline)
  (cond
    [(atom? exp)
      ;;(stack-constant const)
      (cons `(,stack-constant ,exp) code)]
    
    [(symbol? exp)
      ;;(ref-arg symbol) (thaw) 
      (cons `(,ref-arg ,exp) (cons `(,thaw) code))]
    
    [(eq? (car exp) 'quote)
      ;;(stack-constant symbol)
      (cons `(,stack-constant ,(cadr exp)) code)]
    
    [(eq? (car exp) 'define)
      ;;bound (def symbol)
     (compile- `(delay ,(caddr exp)) (cons `(,def ,(cadr exp)) code))]
    
    [(eq? (car exp) 'if)
      ;;bool (sel ((code) (join)) ((code) (join)))
     (let ([t-clause (compile- (caddr exp)  `((,join)))]
           [f-clause (compile- (cadddr exp) `((,join)))])
      (compile- (cadr exp)
        (cons `(,sel ,t-clause ,f-clause) code)))]
    
    [(eq? (car exp) 'lambda)
      ;;(stack-closure symbol ((code) (restore)))
     (let ([body (compile- (caddr exp) `((,restore)))])
       (cons `(,stack-closure ,(cadr exp) ,body) code))]
    
    [(eq? (car exp) 'delay)
     ;;(freeze ((code) (restore)))
     (cons `(,freeze ,(compile- (cadr exp) `((,restore)))) code)]
    
    [else
      ;;arg closure (app)
      (let* ([closure-app (compile- (car exp) (cons `(,app) code))])
        (compile- `(delay ,(cadr exp)) closure-app))]))


;;; experiment ;;;
(print (SECD '() '() (compile 
  
  '(
    ;((lambda x x) 5)
    (define cons- (lambda head (lambda tail (lambda f ((f head) tail)))))
    (define infinite ((cons- 5) infinite)) ;infinit recursion creating a list
    (define car- (lambda lis (lis (lambda head (lambda tail head)))))
    (define cdr- (lambda lis (lis (lambda head (lambda tail tail)))))
    (car- (cdr- infinite))
  )

  ) '() '()))

SECD.scm

;;;; SECD Machine in Scheme ;;;;
;;; 2012 Minori Yamashita <[email protected]> ;;add your name here
;;;
;;; reference:
;;;   http://www.geocities.jp/m_hiroi/func/abcscm33.html
;;;   http://en.wikipedia.org/wiki/SECD_machine
;;;
;;; The description of each instruction is copied from wikipedia.org on 22 Nov 2012

;;; Spec to note ;;;
;; every function take exactly one argument.
;; curry your function manually if you want more than one argument.
;;
;; VM is responsible of looking up the environment unlike the original SECD
;;
;; VM is capable of handling `freeze` and `thaw` instruction which is used to simulate lazy evaluation

(use srfi-1)

;;; Helpers ;;;

;;data structure for closure
(define (data-closure param code env)
  (lambda (f)
    (f param code env)))
(define (cls-param p c e) p)
(define (cls-code  p c e) c)
(define (cls-env   p c e) e)

;;data structure for thunk
(define (data-thunk code env)
  (lambda (f) (f code env)))
(define (thk-code c e) c)
(define (thk-env  c e) e)

;;alias of assq
(define (env-ref env key)
  (let ((binding (assq key env)))
    (if binding (cdr binding) 'lookup-fail)))

;;; SECD Machine ;;;
(define (SECD stack env code dump g-env)
  (print (format "stack: ~S" stack))
  (print (format "env  : ~S" env))
  (print (format "code : ~S" code))
  (print (format "dump : ~S" dump))
  (print (format "g-env: ~S" g-env))
  (newline)

  ;inst        args        stack env code       dump global-env
  ((caar code) (cdar code) stack env (cdr code) dump g-env))


;;; Instructions ;;;

;;ldc
;; pushes a constant argument onto the stack
(define (stack-constant args stack env code dump g-env)
  (SECD
    ;     constant
    (cons (car args) stack) ;S
    env                     ;E
    code                    ;C
    dump                    ;D
    g-env))                  

;;ld
;; pushes the value of a variable onto the stack. 
;; The variable is indicated by the argument, a symbol.
;; Try the local env first then g-env if failed
(define (ref-arg args stack env code dump g-env)
  (let ((val (env-ref env (car args))))
    (SECD
      (cons (if (eq? val 'lookup-fail)
        (env-ref g-env (car args))
        val) stack)                ;S
      env                          ;E
      code                         ;C
      dump                         ;D
      g-env)))

;;sel
;; expects two list arguments, and pops a value from the stack. 
;; The first list is executed if the popped value was non-nil, the second list otherwise. 
;; Before one of these list pointers is made the new C,
;; a pointer to the instruction following sel is saved on the dump.
(define (sel args stack env code dump g-env)
  (SECD
    (cdr stack)                             ;S - bool is poped
    env                                     ;E
    (if (car stack) (car args) (cadr args)) ;C - conditional
    (cons code dump)                        ;D - following code is saved
    g-env))

;;join
;; pops a list reference from the dump and makes this the new value of C. 
;; This instruction occurs at the end of both alternatives of a sel.
(define (join args stack env code dump g-env)
  (SECD
    stack         ;S
    env           ;E
    (car dump)    ;C
    (cdr dump)    ;D
    g-env))

;;ldf
;; takes one list argument representing a function. 
;; It constructs a closure (a pair containing the function and the current environment)
;; and pushes that onto the stack.
(define (stack-closure args stack env code dump g-env)
  (SECD
    ;                   param      code
    (cons (data-closure (car args) (cadr args) env) stack) ;S
    env                                                    ;E
    code                                                   ;C
    dump                                                   ;D
    g-env))

;;ap
;; pops a closure and a list of parameter values from the stack. 
;; The closure is applied to the parameters by installing its environment as the current one, 
;; pushing the parameter list in front of that, clearing the stack, and setting C to the closure's function pointer. 
;; The previous values of S, E, and the next value of C are saved on the dump.
(define (app args stack env code dump g-env)
  (let* (
    (closure   (car stack))
    (clos-prm  (closure cls-param))
    (clos-code (closure cls-code)) ;code enclosed in the closure
    (clos-env  (closure cls-env))) ;enclosed environment
    (SECD
      '()                                          ;S
      ;        symbol      argument
      (cons `(,clos-prm . ,(cadr stack)) clos-env) ;E
      clos-code                                    ;C
      ;           stack-(closure+arg)
      (cons (list (cddr stack) env code) dump)     ;D
      g-env)))

;;ret
;; pops one return value from the stack, 
;; restores S, E, and C from the dump, and pushes the return value onto the now-current stack.
(define (restore args stack env code dump g-env)
  (let* (
    (frame (car dump))
    (restoring-stack (car frame))
    (restoring-env   (cadr frame))
    (restoring-code  (caddr frame)))
    (SECD
      ;     value returned
      (cons (car stack) restoring-stack) ;S
      restoring-env                      ;E
      restoring-code                     ;C
      (cdr dump)                         ;D
      g-env)))

;;def
;; push stack top to g-env
(define (def args stack env code dump g-env)
  (SECD
    (cdr stack) ;S
    env         ;E
    code        ;C
    dump        ;D
    (cons `(,(car args) . ,(car stack)) g-env)))

;;freeze
;; delay the evaluation of the code until thawing
(define (freeze args stack env code dump g-env)
  (SECD
    (cons (data-thunk (car args) env) stack) ;S
    env                                      ;E
    code                                     ;C
    dump                                     ;D
    g-env))

;;thaw
;; evaluate the code inside thunk in its environment
(define (thaw args stack env code dump g-env)
  (let* (
    (thunk (car stack))
    (thunk-code (thunk thk-code))
    (thunk-env  (thunk thk-env)))
   (SECD
     '()                                     ;S
     thunk-env                               ;E
     thunk-code                              ;C
     (cons (list (cdr stack) env code) dump) ;D
     g-env)))

;;stop
;; stops the Machine and return the value at the top of the stack
(define (stop args stack env code dump g-env)
  (car stack))



;;; experiments ;;;
;;((lambda (x) x) 3)
;(display (SECD '() '() `((,stack-constant 3) (,stack-closure x ((,ref-arg x) (,restore))) (,app) (,stop)) '() '())) ;;should be 3
;(newline)
;;(if #f "so true" "so false")
;(display (SECD '() '() `((,stack-constant #f) (,sel ((,stack-constant "so true") (,join)) ((,stack-constant "so false") (,join))) (,stop)) '() '())) ;;should be "so false"
;(newline)
;(print (SECD '() '() `((,stack-closure x ((,stack-constant "hello, world") (,restore))) (,def hello) (,stack-constant 'nil) (,ref-arg hello) (,app) (,stop)) '() '()))
;(print (SECD '() '() `((,freeze ((,stack-constant 5) (,restore))) (,stack-closure x ((,ref-arg x) (,thaw) (,restore))) (,app) (,stop)) '() '())) ;lazy-evaluation ;;should be 5

z.NOTE.txt

オリジナルSECDマシンからの変更点

1: インストラクションの名前は読みやすいものに変えた。
2: クロージャは必ず1引数とした。これで環境が単純になる。
3: 変数の解決はVMで行うこととした。ldはオリジナルでは環境のインデックスを指定するが、ここでは変数名を指定する。これに伴ってldfも引数のシンボルを保持するものとした。
4: グローバル変数の管理のために一つスタックを増やした。(g-env)
5: 遅延評価(今は名前渡し)に対応した。`freeze`がdelay作って、`thaw`がforce

遅延評価付けて無限リスト動いた。