;; -*- Mode: Irken -*-
(define (make-options)
{verbose=#f
nocompile=#f
extra-cflags=""
optimize=#f
trace=#f
debugmacroexpansion=#f
})
(define (make-context)
{datatypes = (alist/make)
macros = (alist/make)
dep-graph = (map-maker symbol-index<?)
scc-graph = '()
vars = (tree/empty)
funs = (tree/empty)
regalloc = (make-register-allocator)
standard-macros = "self/selfmac.scm"
cincludes = '()
cverbatim = '()
records = '()
labels = '()
literals = '()
literal-ids = (tree/empty)
symbols = (alist/make)
variant-labels = (alist/make)
options = (make-options)
exceptions = (alist/make)
}
)
;; XXX a builtin flags object would be nice...
(define (vars-get-var context name)
(match (tree/member context.vars symbol-index<? name) with
(maybe:no) -> (error1 "vars-get-var: no such var" name)
(maybe:yes v) -> v))
(define (vars-get-flag context name flag)
(let ((var (vars-get-var context name)))
(bit-get var.flags flag)))
(define (vars-set-flag! context name flag)
(let ((var (vars-get-var context name)))
(set! var.flags (bit-set var.flags flag))))
(define (vars-inc-calls! context name flag)
(let ((var (vars-get-var context name)))
(set! var.calls (+ 1 var.calls))))
(define VFLAG-RECURSIVE 0) ;; function that is recursive
(define VFLAG-ESCAPES 1) ;; function/variable that escapes
(define VFLAG-FUNCTION 2) ;; variable is a function
(define VFLAG-ALLOCATES 3) ;; function that allocates
(define VFLAG-FREE 4) ;; function that accesses free variables
(define VFLAG-GETCC 5) ;; function uses getcc or putcc (consider calling this NOINLINE)
(define VFLAG-NFLAGS 6)
;; urgh, needs to be an object
(define (add-var name context)
(match (tree/member context.vars symbol-index<? name) with
(maybe:no) -> (set! context.vars
(tree/insert context.vars
symbol-index<? name {flags=0 calls=0 refs=0 sets=0 mult=0}))
;; <fix> then <function>, shows up twice, ignore.
(maybe:yes _) -> #u))
(define (add-vars root context)
(define (add name)
(add-var name context))
(define (search exp)
(match exp.t with
;; only these three bind names.
(node:fix names) -> (for-each add names)
(node:let names) -> (for-each add names)
(node:function name formals) -> (begin (for-each add formals)
(add name))
_ -> #u)
(for-each search exp.subs))
(search root)
)
(define (build-vars root context)
(add-vars root context)
(add-var 'top context))
(define (lookup-label-code label context)
(let loop ((pairs context.labels))
(match pairs with
() -> (error1 "lookup-label-code" label)
((:pair key val) . rest)
-> (if (eq? key label)
val
(loop rest)))))
(define (print-vars context)
(let ((flagpad (+ 2 VFLAG-NFLAGS)))
(print-string "vars = {\n")
(print-string
(format " " (cpad 6 "refs") (cpad 6 "sets") (cpad 6 "calls") (cpad 6 "mult") (lpad flagpad "flags") " " (rpad 30 "name") "\n"))
(tree/inorder
(lambda (k v)
(print-string
(format " "
(lpad 6 (int v.refs))
(lpad 6 (int v.sets))
(lpad 6 (int v.calls))
(lpad 6 (int v.mult))
(lpad flagpad (flags-repr v.flags))
" "
(rpad 30 (sym k))
"\n")))
context.vars)
(print-string "}\n")))