Start to work on Scheme to C translator
parent
985076f2d2
commit
38b8a9fb56
176
ex-5_50-52.scm
176
ex-5_50-52.scm
|
|
@ -1,71 +1,71 @@
|
|||
(load "shared/util")
|
||||
(load "shared/ch5-regsim")
|
||||
(load "shared/ch5-compiler")
|
||||
(load "shared/ch5-eceval-support")
|
||||
|
||||
(display "\nex-5.50 - compile-metacircular-evaluator\n")
|
||||
|
||||
(define mceval-code
|
||||
(let ((port (open-input-file "shared/ch4-mceval.scm")))
|
||||
(read port)))
|
||||
|
||||
(define mceval-compiled
|
||||
(append
|
||||
(list '(assign env (op get-global-environment)))
|
||||
(statements (compile mceval-code 'val 'next))))
|
||||
|
||||
;; write assembly to file for debug purposes
|
||||
; (let ((port (open-output-file "f-mceval-compiled.scm")))
|
||||
; (define (write-list-to-port xs port)
|
||||
; (if (null? xs) '()
|
||||
; (begin (display (car xs) port) (display "\n" port)
|
||||
; (write-list-to-port (cdr xs) port))))
|
||||
; (write-list-to-port mceval-compiled port)
|
||||
; (close-output-port port))
|
||||
|
||||
(define eceval-operations (list
|
||||
(list 'list list)
|
||||
(list 'cons cons)
|
||||
|
||||
(list 'true? true?)
|
||||
(list 'false? false?) ;for compiled code
|
||||
(list 'make-procedure make-procedure)
|
||||
(list 'compound-procedure? compound-procedure?)
|
||||
(list 'procedure-parameters procedure-parameters)
|
||||
(list 'procedure-body procedure-body)
|
||||
(list 'procedure-environment procedure-environment)
|
||||
(list 'extend-environment extend-environment)
|
||||
(list 'lookup-variable-value lookup-variable-value)
|
||||
(list 'set-variable-value! set-variable-value!)
|
||||
(list 'define-variable! define-variable!)
|
||||
(list 'primitive-procedure? primitive-procedure?)
|
||||
(list 'apply-primitive-procedure apply-primitive-procedure)
|
||||
(list 'prompt-for-input prompt-for-input)
|
||||
(list 'announce-output announce-output)
|
||||
(list 'user-print user-print)
|
||||
(list 'empty-arglist empty-arglist)
|
||||
(list 'adjoin-arg adjoin-arg)
|
||||
(list 'last-operand? last-operand?)
|
||||
(list 'no-more-exps? no-more-exps?) ;for non-tail-recursive machine
|
||||
(list 'get-global-environment get-global-environment)
|
||||
|
||||
;;for compiled code (also in eceval-support.scm)
|
||||
(list 'make-compiled-procedure make-compiled-procedure)
|
||||
(list 'compiled-procedure? compiled-procedure?)
|
||||
(list 'compiled-procedure-entry compiled-procedure-entry)
|
||||
(list 'compiled-procedure-env compiled-procedure-env)
|
||||
))
|
||||
|
||||
(define the-global-environment (setup-environment))
|
||||
(define mceval-machine
|
||||
(make-machine
|
||||
'(exp env val proc argl continue unev)
|
||||
eceval-operations
|
||||
mceval-compiled))
|
||||
|
||||
(start mceval-machine)
|
||||
;; (factorial 5) computed by compiled mceval executed by register simulator
|
||||
(assert (get-register-contents mceval-machine 'val) 120)
|
||||
;(load "shared/ch5-regsim")
|
||||
;(load "shared/ch5-compiler")
|
||||
;(load "shared/ch5-eceval-support")
|
||||
;
|
||||
;(display "\nex-5.50 - compile-metacircular-evaluator\n")
|
||||
;
|
||||
;(define mceval-code
|
||||
; (let ((port (open-input-file "shared/ch4-mceval.scm")))
|
||||
; (read port)))
|
||||
;
|
||||
;(define mceval-compiled
|
||||
; (append
|
||||
; (list '(assign env (op get-global-environment)))
|
||||
; (statements (compile mceval-code 'val 'next))))
|
||||
;
|
||||
;;; write assembly to file for debug purposes
|
||||
;; (let ((port (open-output-file "f-mceval-compiled.scm")))
|
||||
;; (define (write-list-to-port xs port)
|
||||
;; (if (null? xs) '()
|
||||
;; (begin (display (car xs) port) (display "\n" port)
|
||||
;; (write-list-to-port (cdr xs) port))))
|
||||
;; (write-list-to-port mceval-compiled port)
|
||||
;; (close-output-port port))
|
||||
;
|
||||
;(define eceval-operations (list
|
||||
; (list 'list list)
|
||||
; (list 'cons cons)
|
||||
;
|
||||
; (list 'true? true?)
|
||||
; (list 'false? false?) ;for compiled code
|
||||
; (list 'make-procedure make-procedure)
|
||||
; (list 'compound-procedure? compound-procedure?)
|
||||
; (list 'procedure-parameters procedure-parameters)
|
||||
; (list 'procedure-body procedure-body)
|
||||
; (list 'procedure-environment procedure-environment)
|
||||
; (list 'extend-environment extend-environment)
|
||||
; (list 'lookup-variable-value lookup-variable-value)
|
||||
; (list 'set-variable-value! set-variable-value!)
|
||||
; (list 'define-variable! define-variable!)
|
||||
; (list 'primitive-procedure? primitive-procedure?)
|
||||
; (list 'apply-primitive-procedure apply-primitive-procedure)
|
||||
; (list 'prompt-for-input prompt-for-input)
|
||||
; (list 'announce-output announce-output)
|
||||
; (list 'user-print user-print)
|
||||
; (list 'empty-arglist empty-arglist)
|
||||
; (list 'adjoin-arg adjoin-arg)
|
||||
; (list 'last-operand? last-operand?)
|
||||
; (list 'no-more-exps? no-more-exps?) ;for non-tail-recursive machine
|
||||
; (list 'get-global-environment get-global-environment)
|
||||
;
|
||||
; ;;for compiled code (also in eceval-support.scm)
|
||||
; (list 'make-compiled-procedure make-compiled-procedure)
|
||||
; (list 'compiled-procedure? compiled-procedure?)
|
||||
; (list 'compiled-procedure-entry compiled-procedure-entry)
|
||||
; (list 'compiled-procedure-env compiled-procedure-env)
|
||||
; ))
|
||||
;
|
||||
;(define the-global-environment (setup-environment))
|
||||
;(define mceval-machine
|
||||
; (make-machine
|
||||
; '(exp env val proc argl continue unev)
|
||||
; eceval-operations
|
||||
; mceval-compiled))
|
||||
;
|
||||
;(start mceval-machine)
|
||||
;;; (factorial 5) computed by compiled mceval executed by register simulator
|
||||
;(assert (get-register-contents mceval-machine 'val) 120)
|
||||
|
||||
;; Uncomment driver loop within shared/ch4-mceval.scm and load in mit-scheme
|
||||
;; for REPL:
|
||||
|
|
@ -91,6 +91,44 @@
|
|||
|
||||
(display "\nex-5.52\n")
|
||||
|
||||
; YAS, almost done!
|
||||
(display "TBD!!!\n")
|
||||
(load "shared/scm2c-compiler")
|
||||
|
||||
; My goal is to compile to C. Not to compile the metacircular evaluator.
|
||||
|
||||
(define c-preamble '(
|
||||
"#include <stdio.h>"
|
||||
""
|
||||
"int main() {"
|
||||
" int val;"
|
||||
" int *argl;"
|
||||
""
|
||||
))
|
||||
|
||||
(define c-epilog '(
|
||||
"}"
|
||||
))
|
||||
|
||||
(define (compile-to-file code)
|
||||
(define (write-list-to-line xs port)
|
||||
(cond
|
||||
((null? xs) '())
|
||||
((pair? xs) (display (car xs) port)
|
||||
(write-list-to-line (cdr xs) port))
|
||||
(else (display xs port))))
|
||||
|
||||
(define (write-list-to-port xs port)
|
||||
(if (null? xs) '()
|
||||
(begin (write-list-to-line (car xs) port)
|
||||
(display "\n" port)
|
||||
(write-list-to-port (cdr xs) port))))
|
||||
(let ((port (open-output-file "main.c"))
|
||||
(stmts (statements (compile code 'val 'next))))
|
||||
(write-list-to-port c-preamble port)
|
||||
(write-list-to-port stmts port)
|
||||
(write-list-to-port c-epilog port)
|
||||
(close-output-port port)))
|
||||
|
||||
(compile-to-file '(+ 1 1))
|
||||
|
||||
; write assembly to file for debug purposes
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,382 @@
|
|||
;;;;COMPILER FROM SECTION 5.5 OF
|
||||
;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS
|
||||
|
||||
;;;;Matches code in ch5.scm
|
||||
|
||||
;;;;This file can be loaded into Scheme as a whole.
|
||||
;;;;**NOTE**This file loads the metacircular evaluator's syntax procedures
|
||||
;;;; from section 4.1.2
|
||||
;;;; You may need to change the (load ...) expression to work in your
|
||||
;;;; version of Scheme.
|
||||
|
||||
;;;;Then you can compile Scheme programs as shown in section 5.5.5
|
||||
|
||||
;;**implementation-dependent loading of syntax procedures
|
||||
(load "shared/sicp-syntax.scm") ;section 4.1.2 syntax procedures
|
||||
|
||||
|
||||
;;;SECTION 5.5.1
|
||||
|
||||
(define (compile exp target linkage)
|
||||
(cond ((self-evaluating? exp)
|
||||
(compile-self-evaluating exp target linkage))
|
||||
((quoted? exp) (compile-quoted exp target linkage))
|
||||
((variable? exp)
|
||||
(compile-variable exp target linkage))
|
||||
((assignment? exp)
|
||||
(compile-assignment exp target linkage))
|
||||
((definition? exp)
|
||||
(compile-definition exp target linkage))
|
||||
((if? exp) (compile-if exp target linkage))
|
||||
((lambda? exp) (compile-lambda exp target linkage))
|
||||
((begin? exp)
|
||||
(compile-sequence (begin-actions exp)
|
||||
target
|
||||
linkage))
|
||||
((cond? exp) (compile (cond->if exp) target linkage))
|
||||
((primitive-procedure? exp)
|
||||
(compile-primitive exp target linkage))
|
||||
((application? exp)
|
||||
(compile-application exp target linkage))
|
||||
(else
|
||||
(error "Unknown expression type -- COMPILE" exp))))
|
||||
|
||||
|
||||
(define (make-instruction-sequence needs modifies statements)
|
||||
(list needs modifies statements))
|
||||
|
||||
(define (empty-instruction-sequence)
|
||||
(make-instruction-sequence '() '() '()))
|
||||
|
||||
;; Implemented in 5.38.
|
||||
(define (primitive-procedure? exp) #f)
|
||||
|
||||
;;;SECTION 5.5.2
|
||||
|
||||
;;;linkage code
|
||||
|
||||
(define (compile-linkage linkage)
|
||||
(cond ((eq? linkage 'return)
|
||||
(make-instruction-sequence '(continue) '()
|
||||
'((goto (reg continue)))))
|
||||
((eq? linkage 'next)
|
||||
(empty-instruction-sequence))
|
||||
(else
|
||||
(make-instruction-sequence '() '()
|
||||
`((goto (label ,linkage)))))))
|
||||
|
||||
(define (end-with-linkage linkage instruction-sequence)
|
||||
(preserving '(continue)
|
||||
instruction-sequence
|
||||
(compile-linkage linkage)))
|
||||
|
||||
|
||||
;;;simple expressions
|
||||
|
||||
(define (compile-self-evaluating exp target linkage)
|
||||
(end-with-linkage linkage
|
||||
(make-instruction-sequence '() (list target)
|
||||
`((" " ,target " " = " " ,exp ";")))))
|
||||
|
||||
(define (compile-quoted exp target linkage)
|
||||
(end-with-linkage linkage
|
||||
(make-instruction-sequence '() (list target)
|
||||
`((assign ,target (const ,(text-of-quotation exp)))))))
|
||||
|
||||
(define (compile-variable exp target linkage)
|
||||
(end-with-linkage linkage
|
||||
(make-instruction-sequence '(env) (list target)
|
||||
`((" "
|
||||
,target " " = " " lookup-variable-value
|
||||
"(" "\"" ,exp "\"" ", " env ")")))))
|
||||
|
||||
(define (compile-assignment exp target linkage)
|
||||
(let ((var (assignment-variable exp))
|
||||
(get-value-code
|
||||
(compile (assignment-value exp) 'val 'next)))
|
||||
(end-with-linkage linkage
|
||||
(preserving '(env)
|
||||
get-value-code
|
||||
(make-instruction-sequence '(env val) (list target)
|
||||
`((perform (op set-variable-value!)
|
||||
(const ,var)
|
||||
(reg val)
|
||||
(reg env))
|
||||
(assign ,target (const ok))))))))
|
||||
|
||||
(define (compile-definition exp target linkage)
|
||||
(let ((var (definition-variable exp))
|
||||
(get-value-code
|
||||
(compile (definition-value exp) 'val 'next)))
|
||||
(end-with-linkage linkage
|
||||
(preserving '(env)
|
||||
get-value-code
|
||||
(make-instruction-sequence '(env val) (list target)
|
||||
`((perform (op define-variable!)
|
||||
(const ,var)
|
||||
(reg val)
|
||||
(reg env))
|
||||
(assign ,target (const ok))))))))
|
||||
|
||||
|
||||
;;;conditional expressions
|
||||
|
||||
;;;labels (from footnote)
|
||||
(define label-counter 0)
|
||||
|
||||
(define (new-label-number)
|
||||
(set! label-counter (+ 1 label-counter))
|
||||
label-counter)
|
||||
|
||||
(define (make-label name)
|
||||
(string->symbol
|
||||
(string-append (symbol->string name)
|
||||
(number->string (new-label-number)))))
|
||||
;; end of footnote
|
||||
|
||||
(define (compile-if exp target linkage)
|
||||
(let ((t-branch (make-label 'true-branch))
|
||||
(f-branch (make-label 'false-branch))
|
||||
(after-if (make-label 'after-if)))
|
||||
(let ((consequent-linkage
|
||||
(if (eq? linkage 'next) after-if linkage)))
|
||||
(let ((p-code (compile (if-predicate exp) 'val 'next))
|
||||
(c-code
|
||||
(compile
|
||||
(if-consequent exp) target consequent-linkage))
|
||||
(a-code
|
||||
(compile (if-alternative exp) target linkage)))
|
||||
(preserving '(env continue)
|
||||
p-code
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence '(val) '()
|
||||
`((test (op false?) (reg val))
|
||||
(branch (label ,f-branch))))
|
||||
(parallel-instruction-sequences
|
||||
(append-instruction-sequences t-branch c-code)
|
||||
(append-instruction-sequences f-branch a-code))
|
||||
after-if))))))
|
||||
|
||||
;;; sequences
|
||||
|
||||
(define (compile-sequence seq target linkage)
|
||||
(if (last-exp? seq)
|
||||
(compile (first-exp seq) target linkage)
|
||||
(preserving '(env continue)
|
||||
(compile (first-exp seq) target 'next)
|
||||
(compile-sequence (rest-exps seq) target linkage))))
|
||||
|
||||
;;;lambda expressions
|
||||
|
||||
(define (compile-lambda exp target linkage)
|
||||
(let ((proc-entry (make-label 'entry))
|
||||
(after-lambda (make-label 'after-lambda)))
|
||||
(let ((lambda-linkage
|
||||
(if (eq? linkage 'next) after-lambda linkage)))
|
||||
(append-instruction-sequences
|
||||
(tack-on-instruction-sequence
|
||||
(end-with-linkage lambda-linkage
|
||||
(make-instruction-sequence '(env) (list target)
|
||||
`((assign ,target
|
||||
(op make-compiled-procedure)
|
||||
(label ,proc-entry)
|
||||
(reg env)))))
|
||||
(compile-lambda-body exp proc-entry))
|
||||
after-lambda))))
|
||||
|
||||
(define (compile-lambda-body exp proc-entry)
|
||||
(let ((formals (lambda-parameters exp)))
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence '(env proc argl) '(env)
|
||||
`(,proc-entry
|
||||
(assign env (op compiled-procedure-env) (reg proc))
|
||||
(assign env
|
||||
(op extend-environment)
|
||||
(const ,formals)
|
||||
(reg argl)
|
||||
(reg env))))
|
||||
(compile-sequence (lambda-body exp) 'val 'return))))
|
||||
|
||||
|
||||
;;;SECTION 5.5.3
|
||||
|
||||
;;;combinations
|
||||
|
||||
(define (compile-application exp target linkage)
|
||||
(let ((proc-code (compile (operator exp) 'proc 'next))
|
||||
(operand-codes
|
||||
(map (lambda (operand) (compile operand 'val 'next))
|
||||
(operands exp))))
|
||||
(preserving '(env continue)
|
||||
proc-code
|
||||
(preserving '(proc continue)
|
||||
(construct-arglist operand-codes)
|
||||
(compile-procedure-call target linkage)))))
|
||||
|
||||
(define (construct-arglist operand-codes)
|
||||
(let ((operand-codes (reverse operand-codes)))
|
||||
(if (null? operand-codes)
|
||||
(make-instruction-sequence '() '(argl)
|
||||
'((assign argl (const ()))))
|
||||
(let ((code-to-get-last-arg
|
||||
(append-instruction-sequences
|
||||
(car operand-codes)
|
||||
(make-instruction-sequence '(val) '(argl)
|
||||
'((" " argl " = " list (val) ";"))))))
|
||||
(if (null? (cdr operand-codes))
|
||||
code-to-get-last-arg
|
||||
(preserving '(env)
|
||||
code-to-get-last-arg
|
||||
(code-to-get-rest-args
|
||||
(cdr operand-codes))))))))
|
||||
|
||||
(define (code-to-get-rest-args operand-codes)
|
||||
(let ((code-for-next-arg
|
||||
(preserving '(argl)
|
||||
(car operand-codes)
|
||||
(make-instruction-sequence '(val argl) '(argl)
|
||||
'((" " argl " " = " " cons "(" val ", " argl ");"))))))
|
||||
(if (null? (cdr operand-codes))
|
||||
code-for-next-arg
|
||||
(preserving '(env)
|
||||
code-for-next-arg
|
||||
(code-to-get-rest-args (cdr operand-codes))))))
|
||||
|
||||
;;;applying procedures
|
||||
|
||||
(define (compile-procedure-call target linkage)
|
||||
(let ((primitive-branch (make-label 'primitive-branch))
|
||||
(compiled-branch (make-label 'compiled-branch))
|
||||
(after-call (make-label 'after-call)))
|
||||
(let ((compiled-linkage
|
||||
(if (eq? linkage 'next) after-call linkage)))
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence '(proc) '()
|
||||
`((test (op primitive-procedure?) (reg proc))
|
||||
(branch (label ,primitive-branch))))
|
||||
(parallel-instruction-sequences
|
||||
(append-instruction-sequences
|
||||
compiled-branch
|
||||
(compile-proc-appl target compiled-linkage))
|
||||
(append-instruction-sequences
|
||||
primitive-branch
|
||||
(end-with-linkage linkage
|
||||
(make-instruction-sequence '(proc argl)
|
||||
(list target)
|
||||
`((assign ,target
|
||||
(op apply-primitive-procedure)
|
||||
(reg proc)
|
||||
(reg argl)))))))
|
||||
after-call))))
|
||||
|
||||
;;;applying compiled procedures
|
||||
|
||||
(define (compile-proc-appl target linkage)
|
||||
(cond ((and (eq? target 'val) (not (eq? linkage 'return)))
|
||||
(make-instruction-sequence '(proc) all-regs
|
||||
`((assign continue (label ,linkage))
|
||||
(assign val (op compiled-procedure-entry)
|
||||
(reg proc))
|
||||
(goto (reg val)))))
|
||||
((and (not (eq? target 'val))
|
||||
(not (eq? linkage 'return)))
|
||||
(let ((proc-return (make-label 'proc-return)))
|
||||
(make-instruction-sequence '(proc) all-regs
|
||||
`((assign continue (label ,proc-return))
|
||||
(assign val (op compiled-procedure-entry)
|
||||
(reg proc))
|
||||
(goto (reg val))
|
||||
,proc-return
|
||||
(assign ,target (reg val))
|
||||
(goto (label ,linkage))))))
|
||||
((and (eq? target 'val) (eq? linkage 'return))
|
||||
(make-instruction-sequence '(proc continue) all-regs
|
||||
'((assign val (op compiled-procedure-entry)
|
||||
(reg proc))
|
||||
(goto (reg val)))))
|
||||
((and (not (eq? target 'val)) (eq? linkage 'return))
|
||||
(error "return linkage, target not val -- COMPILE"
|
||||
target))))
|
||||
|
||||
;; footnote
|
||||
(define all-regs '(env proc val argl continue))
|
||||
|
||||
|
||||
;;;SECTION 5.5.4
|
||||
|
||||
(define (registers-needed s)
|
||||
(if (symbol? s) '() (car s)))
|
||||
|
||||
(define (registers-modified s)
|
||||
(if (symbol? s) '() (cadr s)))
|
||||
|
||||
(define (statements s)
|
||||
(if (symbol? s) (list s) (caddr s)))
|
||||
|
||||
(define (needs-register? seq reg)
|
||||
(memq reg (registers-needed seq)))
|
||||
|
||||
(define (modifies-register? seq reg)
|
||||
(memq reg (registers-modified seq)))
|
||||
|
||||
|
||||
(define (append-instruction-sequences . seqs)
|
||||
(define (append-2-sequences seq1 seq2)
|
||||
(make-instruction-sequence
|
||||
(list-union (registers-needed seq1)
|
||||
(list-difference (registers-needed seq2)
|
||||
(registers-modified seq1)))
|
||||
(list-union (registers-modified seq1)
|
||||
(registers-modified seq2))
|
||||
(append (statements seq1) (statements seq2))))
|
||||
(define (append-seq-list seqs)
|
||||
(if (null? seqs)
|
||||
(empty-instruction-sequence)
|
||||
(append-2-sequences (car seqs)
|
||||
(append-seq-list (cdr seqs)))))
|
||||
(append-seq-list seqs))
|
||||
|
||||
(define (list-union s1 s2)
|
||||
(cond ((null? s1) s2)
|
||||
((memq (car s1) s2) (list-union (cdr s1) s2))
|
||||
(else (cons (car s1) (list-union (cdr s1) s2)))))
|
||||
|
||||
(define (list-difference s1 s2)
|
||||
(cond ((null? s1) '())
|
||||
((memq (car s1) s2) (list-difference (cdr s1) s2))
|
||||
(else (cons (car s1)
|
||||
(list-difference (cdr s1) s2)))))
|
||||
|
||||
(define (preserving regs seq1 seq2)
|
||||
(if (null? regs)
|
||||
(append-instruction-sequences seq1 seq2)
|
||||
(let ((first-reg (car regs)))
|
||||
(if (and (needs-register? seq2 first-reg)
|
||||
(modifies-register? seq1 first-reg))
|
||||
(preserving (cdr regs)
|
||||
(make-instruction-sequence
|
||||
(list-union (list first-reg)
|
||||
(registers-needed seq1))
|
||||
(list-difference (registers-modified seq1)
|
||||
(list first-reg))
|
||||
(append `((save ,first-reg))
|
||||
(statements seq1)
|
||||
`((restore ,first-reg))))
|
||||
seq2)
|
||||
(preserving (cdr regs) seq1 seq2)))))
|
||||
|
||||
(define (tack-on-instruction-sequence seq body-seq)
|
||||
(make-instruction-sequence
|
||||
(registers-needed seq)
|
||||
(registers-modified seq)
|
||||
(append (statements seq) (statements body-seq))))
|
||||
|
||||
(define (parallel-instruction-sequences seq1 seq2)
|
||||
(make-instruction-sequence
|
||||
(list-union (registers-needed seq1)
|
||||
(registers-needed seq2))
|
||||
(list-union (registers-modified seq1)
|
||||
(registers-modified seq2))
|
||||
(append (statements seq1) (statements seq2))))
|
||||
|
||||
'(COMPILER LOADED)
|
||||
Loading…
Reference in New Issue