;; -*- Mode: Irken -*-
(define (make-context)
{datatypes = (alist/make)
macros = (alist/make)
dep-graph = (alist-maker)
scc-graph = '()
vars = (tree:empty)
regalloc = (make-register-allocator)
standard-macros = "self/selfmac.scm"
records = '()
labels = '()
}
)
;; XXX a builtin flags object would be nice...
(define (vars-get-var context name)
(match (tree/member context.vars symbol<? 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-NFLAGS 5)
(define (build-vars root context)
(let ((vars context.vars))
(define (add-var name)
(match (tree/member vars symbol<? name) with
(maybe:no) -> (set! vars (tree/insert vars symbol<? name {flags=0 calls=0 refs=0 sets=0 mult=0}))
(maybe:yes _) -> #u)) ;; fix then function, shows up twice, ignore.
(define (search exp)
(match exp.t with
;; only these three bind names.
(node:fix names) -> (for-each add-var names)
(node:let names) -> (for-each add-var names)
(node:function name formals) -> (begin (for-each add-var formals)
(add-var name))
_ -> #u)
(for-each search exp.subs))
(search root)
(add-var 'top)
(set! context.vars vars)))
(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")))