;; -*- Mode: Irken -*-
(include "self/backend.scm")
(define (find-base path)
(let ((parts (string-split path #\.))
(rparts (reverse parts)))
(if (not (string=? (first rparts) "scm"))
(error1 "find-base" path)
(string-join (reverse (cdr rparts)) "."))))
(define (read-template)
(let ((ifile (file/open-read "header.c")))
(let loop ((buf (file/read-buffer ifile))
(l '()))
(cond ((= (string-length buf) 0) (string-concat (reverse l)))
(else (loop (file/read-buffer ifile)
(list:cons buf l)))))))
(define sentinel0 "// CONSTRUCTED LITERALS //\n")
(define sentinel1 "// REGISTER_DECLARATIONS //\n")
(define (get-header-parts)
(let ((header (read-template))
(pos0 (string-find sentinel0 header))
(pos1 (string-find sentinel1 header))
)
(if (or (= pos0 -1) (= pos1 -1))
(error1 "template strings not found in header.c?" (:pair pos0 pos1))
(let ((pos0 (+ pos0 (string-length sentinel0)))
(pos1 (+ pos1 (string-length sentinel1)))
(part0 (substring header 0 pos0))
(part1 (substring header pos0 pos1))
(part2 (substring header pos1 (string-length header))))
(:header part0 part1 part2)))))
(define (prepend-standard-macros forms context)
(foldr list:cons forms (read-file context.standard-macros)))
(define (system cmd)
(%%cexp (string -> int) "system (%0)" cmd))
(define (main)
(if (< sys.argc 2)
(error "Usage: compile <irken-src-file>"))
(let ((context (make-context))
(transform (transformer context))
(path sys.argv[1])
(base (find-base path))
(opath (string-append base ".c"))
(forms0 (read-file path))
(forms1 (prepend-standard-macros forms0 context))
(exp0 (sexp:list forms1))
(exp1 (transform exp0))
(_ (begin (pp 0 exp1) (newline)))
(node0 (walk exp1))
(node0 (apply-substs node0))
(_ (rename-variables node0))
(_ (begin (pp-node node0 4) newline))
(_ (build-dependency-graph node0 context))
(_ (print-graph context.dep-graph))
(strong (strongly context.dep-graph))
(_ (printn strong))
(_ (set! context.scc-graph strong))
(_ (analyze node0 context))
(node1 (do-simple-optimizations node0))
(node2 (do-inlining node1 context))
(node3 (do-trim node2 context))
(noden (do-simple-optimizations node3))
(type0 (type-program noden context))
)
(print-string "\n-- reader --\n")
(unread exp0)
(newline)
(print-string "\n-- macros --\n")
(unread exp1)
(newline)
(print-string "\n-- node tree --\n")
(pp-node node1 4) (newline)
(print-string "\n-- after inlining --\n")
(pp-node node2 4) (newline)
(print-string "\n-- after trimming --\n")
(pp-node noden 4) (newline)
(let ((cps (compile noden context))
(ofile (file/open-write opath #t #o644))
(o (make-writer ofile)))
(print-string "\n-- RTL --\n")
(print-insn cps 0)
(newline)
;(iterate-insns cps)
(print-string "\n-- datatypes --\n")
(alist/iterate
(lambda (name dt)
(print-datatype dt))
context.datatypes)
(print-string "\n-- variables --\n")
(print-vars context)
(print-string "\n-- labels --\n")
(printn context.labels)
(print-string "\n-- records --\n")
(printn context.records)
(print-string "\n-- C output --\n")
(print-string " : ") (print-string opath) (newline)
(match (get-header-parts) with
(:header part0 part1 part2)
-> (begin (o.copy part0)
(o.copy part1)
(emit-registers o context)
(o.copy part2)
(emit o cps context)))
(print-string "done.\n")
(o.close)
(print-string "compiling...\n")
(let ((cmd (format "/usr/local/bin/gcc -I. -g -m64 " opath " -o " base)))
(print-string cmd) (newline)
(system cmd))
)
)
)
(main)