;; -*- Mode: Irken -*-
(include "self/cps.scm")
(include "self/typing.scm")
(include "self/graph.scm")
(include "self/analyze.scm")
(define (make-writer file)
(let ((level 1))
(define (write-indent)
(let loop ((i level))
(cond ((> i 0)
(write file.fd " ")
(loop (- i 1))))))
(define (write-string s)
(write-indent)
(write file.fd s)
(write file.fd "\n")
#u)
(define (copy s)
(write file.fd s))
(define (indent) (set! level (+ level 1)))
(define (dedent) (set! level (- level 1)))
(define (close-file) (close file.fd))
{write=write-string indent=indent dedent=dedent copy=copy close=close-file}
))
(define (make-name-frobber)
(define safe-name-map
(literal
(alist/make
(#\! "_bang")
(#\* "_splat")
(#\? "_question")
(#\- "_")
(#\+ "_plus")
(#\% "_percent")
)))
(define c-legal? (char-class (string->list "abcdefghijklmnopqrstuvwxyz_0123456789")))
(define (frob-name name)
(define (frob)
(let loop ((i 0) (r '()))
(if (= i (string-length name))
r
(let ((ch (string-ref name i)))
(loop (+ i 1)
(list:cons
(if (c-legal? ch)
(char->string ch)
(match (alist/lookup safe-name-map ch) with
(maybe:yes sub) -> sub
(maybe:no) -> (format "_" (hex (char->ascii ch)))))
r))))))
(let ((r (string-concat (reverse (frob)))))
(if (string=? r "_")
;; special-case
"minus"
r)))
frob-name)
(define label-maker
(let ((counter (make-counter 0)))
(lambda ()
(format "L" (int (counter.inc))))))
(define encode-immediate
(literal:int n) -> (logior 1 (<< n 1))
(literal:char ch) -> (logior 2 (<< (char->ascii ch) 8))
(literal:undef) -> #x0e
(literal:cons 'bool 'true _) -> #x106
(literal:cons 'bool 'false _) -> #x006
x -> (error1 "expected immediate literal " x))
(define (wrap-in type arg)
(match type with
(type:tvar id _) -> arg
(type:pred name predargs _)
-> (match name with
'int -> (format "unbox(" arg ")")
'string -> (format "((pxll_string*)(" arg "))->data")
'cstring -> (format "(char*)" arg)
'buffer -> (format "(" (irken-type->c-type type) "(((pxll_vector*)" arg ")+1))")
'ptr -> arg
'arrow -> arg
'vector -> arg
'symbol -> arg
'char -> arg
'continuation -> arg
'raw -> (match predargs with
((type:pred 'string _ _)) -> (format "((pxll_string*)(" arg "))")
_ -> (error1 "unknown raw type in %cexp" type))
kind -> (if (member-eq? kind c-int-types)
(format "unbox(" arg ")")
(error1 "wrap-in:" type))
)))
;; (buffer (struct sockaddr_t)) => (struct sockaddr_t *)
(define (irken-type->c-type t)
(match t with
(type:pred 'buffer (arg) _) -> (format "(" (irken-type->c-type arg) "*)")
(type:pred 'struct (arg) _) -> (format "struct " (irken-type->c-type arg))
(type:pred name () _) -> (format (sym name))
_ -> (error1 "malformed ctype" (type-repr t))))
;;
;; ok, for *now*, I don't really want subtyping. but I *do* want
;; automatic casting/conversion... what's the cleanest way to get that?
;; We have to deal with both typing and code generation.
;;
(define c-int-types
;; XXX distinguish between signed and unsigned!
;; XXX also need to handle 64-bit types on a 32-bit platform.
'(uint8_t uint16_t uint32_t uint64_t
int8_t int16_t int32_t int64_t))
(define (wrap-out type exp)
(match type with
(type:pred 'int _ _) -> (format "box((pxll_int)" exp ")")
(type:pred 'bool _ _) -> (format "PXLL_TEST(" exp ")")
(type:pred 'cstring _ _) -> (format "(object*)" exp)
(type:pred 'ptr _ _) -> (format "(object*)" exp)
(type:pred kind _ _) -> (if (member-eq? kind c-int-types)
(format "box((pxll_int)" exp ")")
exp)
_ -> exp
))
;; substitute <values> into <template>, e.g. "%0 + %1" ("unbox(r3)" "unbox(r5)") => "r3
(define (cexp-subst template values)
(let ((split (string-split template #\%)))
(let loop ((r (LIST (car split)))
(l (cdr split)))
(match l with
;; wouldn't it be cool to generalize pattern matching to strings somehow?
() -> (string-concat (reverse r))
("") -> (error1 "malformed cexp template string" template) ;; template should not end with %
("" x . tl) -> (loop (prepend x "%" r) tl) ;; %% causes this
(x . tl) -> (match (alist/lookup dec-map (string-ref x 0)) with
(maybe:no) -> (error1 "malformed cexp template string" template)
(maybe:yes n) -> (loop (prepend (substring x 1 (string-length x))
(nth values n)
r)
tl))))))
(define (emit o insns context)
(define emitk
(cont:k _ _ k) -> (emit k)
(cont:nil) -> #u)
(define (emit insn)
(emitk
(match insn with
(insn:return target) -> (begin (o.write (format "PXLL_RETURN(" (int target) ");")) (cont:nil))
(insn:literal lit k) -> (begin (emit-literal lit (k/target k)) k)
(insn:litcon i kind k) -> (begin (emit-litcon i kind (k/target k)) k)
(insn:test reg k0 k1 k) -> (begin (emit-test reg k0 k1) k)
(insn:testcexp regs sig tmpl k0 k1 k) -> (begin (emit-testcexp regs sig tmpl k0 k1) k)
(insn:jump reg target) -> (begin (emit-jump reg target) (cont:nil))
(insn:cexp sig type template args k) -> (begin (emit-cexp sig type template args (k/target k)) k)
(insn:close name body k) -> (begin (emit-close name body (k/target k)) k)
(insn:varref d i k) -> (begin (emit-varref d i (k/target k)) k)
(insn:varset d i v k) -> (begin (emit-varset d i v) k)
(insn:new-env size top? k) -> (begin (emit-new-env size top? (k/target k)) k)
(insn:alloc tag size k) -> (begin (emit-alloc tag size (k/target k)) k)
(insn:store off arg tup i k) -> (begin (emit-store off arg tup i) k)
(insn:invoke name fun args k) -> (begin (emit-call name fun args k) k)
(insn:tail name fun args) -> (begin (emit-tail name fun args) (cont:nil))
(insn:trcall d n args) -> (begin (emit-trcall d n args) (cont:nil))
(insn:push r k) -> (begin (emit-push r) k)
(insn:pop r k) -> (begin (emit-pop r (k/target k)) k)
(insn:primop name parm t args k) -> (begin (emit-primop name parm t args k) k)
(insn:move dst var k) -> (begin (emit-move dst var (k/target k)) k)
(insn:fatbar lab k0 k1 k) -> (begin (emit-fatbar lab k0 k1) k)
(insn:fail label npop) -> (begin (emit-fail label npop) (cont:nil))
(insn:nvcase tr dt tags alts ealt k) -> (begin (emit-nvcase tr dt tags alts ealt) k)
(insn:pvcase tr tags arities alts ealt k) -> (begin (emit-pvcase tr tags arities alts ealt) k)
)))
(define (move src dst)
(if (and (>= dst 0) (not (= src dst)))
(o.write (format "r" (int dst) " = r" (int src) ";"))))
(define (emit-literal lit target)
(let ((val (encode-immediate lit))
(prefix (if (= target -1)
"// dead " ;; why bother with a dead literal?
(format "r" (int target)))))
(o.write (format prefix " = (object *) " (int val) ";"))
))
(define (emit-litcon index kind target)
(if (>= target 0)
(cond ((eq? kind 'string)
(o.write (format "r" (int target) " = (object*) &constructed_" (int index) ";")))
(else
(o.write (format "r" (int target) " = (object *) constructed_" (int index) "[0];"))))))
(define (emit-test reg k0 k1)
(o.write (format "if PXLL_IS_TRUE(r" (int reg)") {"))
(o.indent)
(emit k0)
(o.dedent)
(o.write "} else {")
(o.indent)
(emit k1)
(o.dedent)
(o.write "}"))
(define (emit-testcexp args sig template k0 k1)
;; we know we're testing a cexp, just inline it here
(match sig with
(type:pred 'arrow (result-type . arg-types) _)
-> (let ((args0 (map (lambda (reg) (format "r" (int reg))) args))
(args1 (map2 wrap-in arg-types args0))
(exp (wrap-out result-type (cexp-subst template args1))))
(o.write (format "if PXLL_IS_TRUE(" exp ") {"))
(o.indent)
(emit k0)
(o.dedent)
(o.write "} else {")
(o.indent)
(emit k1)
(o.dedent)
(o.write "}"))
_ -> (impossible)))
(define (emit-jump reg target)
(move reg target))
;; XXX consider this: giving access to the set of free registers.
;; would make it possible to do %ensure-heap in a %%cexp.
(define (emit-cexp sig type template args target)
(let ((exp
(match sig with
(type:pred 'arrow (result-type . arg-types) _)
-> (let ((args0 (map (lambda (reg) (format "r" (int reg))) args))
(args1 (map2 wrap-in arg-types args0)))
;; from the sig
;;(wrap-out result-type (cexp-subst template args1))
;; the solved type
(wrap-out type (cexp-subst template args1))
)
;; some constant type
_ -> (wrap-out sig template))))
(if (= target -1)
(o.write (format exp ";"))
(o.write (format "r" (int target) " = " exp ";")))))
(define frob-name (make-name-frobber))
(define (gen-function-label sym)
(format "FUN_" (frob-name (symbol->string sym))))
(define (emit-close name body target)
(let ((proc-label (gen-function-label name))
(jump-label (label-maker)))
;; emit a jump over the function definition
(o.write (format "// def " (sym name)))
(o.write (format "goto " jump-label ";"))
;; emit the function definition
(o.write (format proc-label ":"))
(o.indent)
;; XXX context flag for this...
(if context.options.trace
(o.write (format "stack_depth_indent(k); fprintf (stderr, \">> [%d] " proc-label "\\n\", __LINE__);")))
(if (vars-get-flag context name VFLAG-ALLOCATES)
(o.write "check_heap (0);"))
(emit body)
(o.dedent)
(o.write (format jump-label ":"))
(o.write (format "r" (int target) " = allocate (TC_CLOSURE, 2);"))
(o.write (format "r" (int target) "[1] = &&" proc-label "; r" (int target) "[2] = lenv;"))
))
(define (emit-varref d i target)
(if (>= target 0)
(let ((src
(if (= d -1)
(format "top[" (int (+ 2 i)) "];") ;; the +2 is to skip the header and next ptr
;;(format "varref (" (int d) "," (int i) ");")
(format "((object*" (repeat d "*") ") lenv) " (repeat d "[1]") "[" (int (+ i 2)) "];")
)))
(o.write (format "r" (int target) " = " src)))))
(define (emit-varset d i v)
(if (= d -1)
(o.write (format "top[" (int (+ 2 i)) "] = r" (int v) ";"))
;;(o.write (format "varset (" (int d) ", " (int i) ", r" (int v) ");"))
(o.write (format "((object*" (repeat d "*") ") lenv) " (repeat d "[1]") "[" (int (+ i 2)) "] = r" (int v) ";"))
))
(define (emit-new-env size top? target)
(o.write (format "r" (int target) " = allocate (TC_TUPLE, " (int (+ size 1)) ");"))
(if top?
(o.write (format "top = r" (int target) ";"))))
(define (emit-alloc tag size target)
(let ((tag-string
(match tag with
(tag:bare v) -> (format (int v))
(tag:uobj v) -> (format (if (= size 0) "UITAG(" "UOTAG(") (int v) ")"))))
(if (= size 0)
;; unit type - use an immediate
(o.write (format "r" (int target) " = (object*)" tag-string ";"))
(o.write (format "r" (int target) " = allocate (" tag-string ", " (int size) ");")))))
(define (emit-store off arg tup i)
(o.write (format "r" (int tup) "[" (int (+ 1 (+ i off))) "] = r" (int arg) ";")))
(define (emit-tail name fun args)
(let ((goto
(match name with
(maybe:no) -> (format "goto *r" (int fun) "[1];")
(maybe:yes name) -> (format "goto " (gen-function-label name) ";"))))
(if (>= args 0)
(o.write (format "r" (int args) "[1] = r" (int fun) "[2]; lenv = r" (int args) "; " goto))
(o.write (format "lenv = r" (int fun) "[2]; " goto))
)))
(define (emit-call name fun args k)
(let ((free (sort < (k/free k))) ;; sorting these might improve things
(return-label (label-maker))
(nregs (length free))
(target (k/target k)))
;; save
(o.write (format "t = allocate (TC_SAVE, " (int (+ 3 nregs)) ");"))
(let ((saves
(map-range
i nregs
(format "t[" (int (+ i 4)) "] = r" (int (nth free i))))))
(o.write (format "t[1] = k; t[2] = lenv; t[3] = &&" return-label "; " (string-join saves "; ") "; k = t;")))
;; call
(let ((goto
(match name with
;; strange - LLVM actually slows down if I jump to a known label.
(maybe:no) -> (format "goto *r" (int fun) "[1];")
(maybe:yes name) -> (format "goto " (gen-function-label name) ";"))))
(if (>= args 0)
(o.write (format "r" (int args) "[1] = r" (int fun) "[2]; lenv = r" (int args) "; " goto))
(o.write (format "lenv = r" (int fun) "[2]; " goto))))
;; label
(o.write (format return-label ":"))
;; restore
(let ((restores
(map-range
i nregs
(format "r" (int (nth free i)) " = k[" (int (+ i 4)) "]"))))
(o.write (format (string-join restores "; ") "; lenv = k[2]; k = k[1];")))
(if (>= target 0)
(o.write (format "r" (int target) " = result;")))
))
(define (emit-trcall depth name regs)
(let ((nargs (length regs))
(npop (- depth 1)))
(if (= nargs 0)
;; a zero-arg trcall needs an extra level of pop
(set! npop (+ npop 1)))
(if (> npop 0)
(o.write (format "lenv = ((object " (joins (n-of npop "*")) ")lenv)" (joins (n-of npop "[1]")) ";")))
(for-range
i nargs
(o.write (format "lenv[" (int (+ 2 i)) "] = r" (int (nth regs i)) ";")))
(o.write (format "goto " (gen-function-label name) ";"))))
(define (emit-push args)
(o.write (format "r" (int args) "[1] = lenv; lenv = r" (int args) ";")))
(define (emit-pop src target)
(o.write (format "lenv = lenv[1];"))
(move src target))
(define (subset? a b)
(every? (lambda (x) (member-eq? x b)) a))
(define (guess-record-type sig)
;; can we disambiguate this record signature?
(let ((sig (map (lambda (x) ;; remove sexp wrapping
(match x with
(sexp:symbol field) -> field
_ -> (impossible))) sig))
(sig (filter (lambda (x) (not (eq? x '...))) sig)))
(let ((candidates '()))
(for-each
(lambda (x)
(match x with
(:pair sig0 index0)
-> (if (subset? sig sig0)
(PUSH candidates sig0))))
context.records)
(if (= 1 (length candidates))
;; unambiguous - there's only one possible match.
(maybe:yes (nth candidates 0))
;; this sig is ambiguous given the set of known records.
(maybe:no)))))
;; hacks for datatypes known by the runtime
(define (get-uotag dtname altname index)
(match dtname altname with
'list 'cons -> "TC_PAIR"
'symbol 't -> "TC_SYMBOL"
_ _ -> (format "UOTAG(" (int index) ")")))
(define (get-uitag dtname altname index)
(match dtname altname with
'list 'nil -> "TC_NIL"
'bool 'true -> "(pxll_int)PXLL_TRUE"
'bool 'false -> "(pxll_int)PXLL_FALSE"
_ _ -> (format "UITAG(" (int index) ")")))
(define (emit-primop name parm type args k)
(define (primop-error)
(error1 "primop" name))
(let ((target (k/target k))
(nargs (length args)))
;; these need to be broken up into separate functions...
(match name with
'%dtcon -> (match parm with
(sexp:cons dtname altname)
-> (match (alist/lookup context.datatypes dtname) with
(maybe:no) -> (error1 "emit-primop: no such datatype" dtname)
(maybe:yes dt)
-> (let ((alt (dt.get altname)))
(cond ((= nargs 0)
(o.write (format "r" (int target) " = (object*)" (get-uitag dtname altname alt.index) ";")))
(else
(o.write (format "t = alloc_no_clear (" (get-uotag dtname altname alt.index) "," (int nargs) ");"))
(for-range
i nargs
(o.write (format "t[" (int (+ i 1)) "] = r" (int (nth args i)) ";")))
(o.write (format "r" (int target) " = t;"))))))
_ -> (primop-error)
)
'%nvget -> (match parm args with
(sexp:list (_ (sexp:int index) _)) (reg)
-> (o.write (format "r" (int target) " = UOBJ_GET(r" (int reg) "," (int index) ");"))
_ _ -> (primop-error))
'%make-vector -> (match args with
(vlen vval)
-> (begin
;; since we cannot know the size at compile-time, there should
;; always be a call to ensure_heap() before any call to %make-vector
(o.write (format "if (unbox(r" (int vlen) ") == 0) { r" (int target) " = (object *) TC_EMPTY_VECTOR; } else {"))
(o.write (format " t = alloc_no_clear (TC_VECTOR, unbox(r" (int vlen) "));"))
(o.write (format " for (i=0; i<unbox(r" (int vlen) "); i++) { t[i+1] = r" (int vval) "; }"))
(o.write (format " r" (int target) " = t;"))
(o.write "}"))
_ -> (primop-error))
'%array-ref -> (match args with
(vec index)
-> (begin
(o.write (format "range_check (GET_TUPLE_LENGTH(*(object*)r" (int vec) "), unbox(r" (int index)"));"))
(o.write (format "r" (int target) " = ((pxll_vector*)r" (int vec) ")->val[unbox(r" (int index) ")];")))
_ -> (primop-error))
'%array-set -> (match args with
(vec index val)
-> (begin
(o.write (format "range_check (GET_TUPLE_LENGTH(*(object*)r" (int vec) "), unbox(r" (int index)"));"))
(o.write (format "((pxll_vector*)r" (int vec) ")->val[unbox(r" (int index) ")] = r" (int val) ";")))
_ -> (primop-error))
'%record-get -> (match parm args with
(sexp:list ((sexp:symbol label) (sexp:list sig))) (rec-reg)
-> (let ((label-code (lookup-label-code label context)))
(match (guess-record-type sig) with
(maybe:yes sig0)
-> (o.write (format "r" (int target) ;; compile-time lookup
" = ((pxll_vector*)r" (int rec-reg)
")->val[" (int (index-eq label sig0))
"];"))
(maybe:no)
-> (o.write (format "r" (int target) ;; run-time lookup
" = ((pxll_vector*)r" (int rec-reg)
")->val[lookup_field((GET_TYPECODE(*r" (int rec-reg)
")-TC_USEROBJ)>>2," (int label-code)
")];"))))
_ _ -> (primop-error))
;; XXX very similar to record-get, maybe some way to collapse the code?
'%record-set -> (match parm args with
(sexp:list ((sexp:symbol label) (sexp:list sig))) (rec-reg arg-reg)
-> (let ((label-code (lookup-label-code label context)))
(match (guess-record-type sig) with
(maybe:yes sig0)
-> (o.write (format "((pxll_vector*)r" (int rec-reg) ;; compile-time lookup
")->val[" (int (index-eq label sig0))
"] = r" (int arg-reg) ";"))
(maybe:no)
-> (o.write (format "((pxll_vector*)r" (int rec-reg) ;; run-time lookup
")->val[lookup_field((GET_TYPECODE(*r" (int rec-reg)
")-TC_USEROBJ)>>2," (int label-code)
")] = r" (int arg-reg) ";"))))
_ _ -> (primop-error))
'%ensure-heap -> (o.write (format "ensure_heap (" (int (length (k/free k))) ", unbox(r" (int (car args)) "));"))
'%callocate -> (let ((type (parse-type parm))) ;; gets parsed twice, convert to %%cexp?
;; XXX maybe make alloc_no_clear do an ensure_heap itself?
(if (>= target 0)
(o.write (format "r" (int target) " = alloc_no_clear (TC_BUFFER, HOW_MANY (sizeof (" (irken-type->c-type type)
") * unbox(r" (int (car args)) "), sizeof (object)));"))
(error1 "%callocate: dead target?" type)))
'%exit -> (o.write (format "PXLL_UNDEFINED; result=r" (int (car args)) "; goto Lreturn;"))
'%cget -> (match args with
(rbase rindex)
;; XXX range-check (probably need to add a length param to TC_BUFFER)
-> (let ((cexp (format "(((" (type-repr type) "*)((pxll_int*)r" (int rbase) ")+1)[" (int rindex) "])")))
(o.write (format "r" (int target) " = " (wrap-out type cexp) ";")))
_ -> (primop-error))
'%cset -> (match args type with
(rbase rindex rval) (type:pred 'arrow (to-type from-type) _)
;; XXX range-check (probably need to add a length param to TC_BUFFER)
-> (let ((rval-exp (lookup-cast to-type from-type (format "r" (int rval))))
(lval (format "(((" (type-repr to-type) "*)((pxll_int*)r" (int rbase) ")+1)[" (int rindex) "])")))
(o.write (format lval " = " rval-exp ";")))
_ _ -> (primop-error))
'%getcc -> (match args with
() -> (o.write (format "r" (int target) " = k; // %getcc"))
_ -> (primop-error))
'%putcc -> (match args with
(rk rv) -> (begin
(o.write (format "k = r" (int rk) "; // %putcc"))
(move rv target))
_ -> (primop-error))
_ -> (primop-error))))
(define (lookup-cast to-type from-type exp)
(match to-type from-type with
(type:pred tout _ _) (type:pred 'int _ _)
-> (if (member-eq? tout c-int-types)
(format "((" (sym tout) ")unbox(" exp "))")
(error1 "lookup-cast: can't cast from int to: " tout))
_ _ -> (error1 "lookup-cast: unable to cast between types: " (:pair to-type from-type))))
(define (emit-move var src target)
(cond ((and (>= src 0) (not (= src var)))
;; from varset
(o.write (format "r" (int var) " = r" (int src) ";")))
((and (>= target 0) (not (= target var)))
;; from varref
(o.write (format "r" (int target) " = r" (int var) ";")))))
(define (emit-fatbar label k0 k1)
(emit k0)
(o.write (format "goto fatbar_" (int label) "_over;"))
(o.write (format "fatbar_" (int label) ":"))
(emit k1)
;; Note: the extra semicolon here is necessary because C99 requires a 'statement'
;; to follow a label. Sometimes there's no code after the label, so this avoids
;; that problem. [might be possible to look at the insn's continuation instead]
(o.write (format "fatbar_" (int label) "_over: ;")))
(define (emit-fail label npop)
(if (> npop 0)
(o.write (format "lenv = ((object " (joins (n-of npop "*")) ")lenv)" (joins (n-of npop "[1]")) ";")))
(o.write (format "goto fatbar_" (int label) ";")))
(define (which-typecode-fun dt) "get_case") ;; XXX
(define (emit-nvcase test dtname tags subs ealt)
(let ((use-else? (maybe? ealt)))
(match (alist/lookup context.datatypes dtname) with
(maybe:no) -> (error1 "emit-nvcase" dtname)
(maybe:yes dt)
-> (if (and (= (length subs) 1) (= (dt.get-nalts) 1))
;; nothing to switch on, just emit the code
(emit (nth subs 0))
(let ((get-typecode (which-typecode-fun dt)))
(o.write (format "switch (" get-typecode " (r" (int test) ")) {"))
;; XXX reorder tags to put immediate tests first!
(for-range
i (length tags)
(let ((label (nth tags i))
(sub (nth subs i))
(alt (dt.get label))
(arity alt.arity)
(uimm #f)
(tag (if (= arity 0) ;; immediate/unit constructor
(get-uitag dtname label alt.index)
(get-uotag dtname label alt.index))))
(o.indent)
(if (and (not use-else?) (= i (- (length tags) 1)))
(o.write "default: {")
(o.write (format "case (" tag "): {")))
(o.indent)
(emit sub)
(o.dedent)
(o.write "} break;")
(o.dedent)
))
(match ealt with
(maybe:yes ealt0)
-> (begin
(o.indent)
(o.write "default: {")
(o.indent)
(emit ealt0)
(o.dedent)
(o.write "}")
(o.dedent))
_ -> #u)
(o.write "}"))))))
(define (emit-pvcase test-reg tags arities alts ealt)
(o.write (format "switch (get_case_noint (r" (int test-reg) ")) {"))
(let ((else? (maybe? ealt))
(n (length alts)))
(for-range
i n
(let ((label (nth tags i))
(arity (nth arities i))
(alt (nth alts i))
(tag0 (match (alist/lookup context.variant-labels label) with
(maybe:yes v) -> v
(maybe:no) -> (error1 "variant constructor never called" label)))
(tag1 (format (if (= arity 0) "UITAG(" "UOTAG(") (int tag0) ")"))
(case0 (format "case (" tag1 "): {"))
(case1 (if (and (not else?) (= i (- n 1))) "default: {" case0)))
(o.indent)
(o.write case1)
(o.indent)
(emit alt)
(o.dedent)
(o.write "} break;")
(o.dedent)))
(match ealt with
(maybe:yes ealt)
-> (begin
(o.indent)
(o.write (format "default: {"))
(o.indent)
(emit ealt)
(o.dedent)
(o.write "};")
(o.dedent))
(maybe:no) -> #u)
(o.write "}")))
;; body of emit
(emit insns)
(o.write "Lreturn:")
(o.write "return (pxll_int) result;")
(o.dedent)
(o.write "}")
)
(define (emit-registers o context)
(let ((nreg (+ 1 (context.regalloc.get-max))))
(for-range
i nreg
(o.write (format "register object * r" (int i) ";")))
(o.write "void gc_regs_in (int n) {")
(o.write " switch (n) {")
(for-each
(lambda (i)
(o.write (format " case " (int (+ i 1)) ": heap1[" (int (+ i 3)) "] = r" (int i) ";")))
(reverse (range nreg)))
(o.write "}}")
(o.write "void gc_regs_out (int n) {")
(o.write " switch (n) {")
(for-each
(lambda (i)
(o.write (format " case " (int (+ i 1)) ": r" (int i) " = heap0[" (int (+ i 3)) "];")))
(reverse (range nreg)))
(o.write "}}")))
;; we support three types of non-immediate literals:
;;
;; 1) strings. identical strings are *not* merged, since
;; modifying strings is a reasonable choice.
;; 2) symbols. this emits a string followed by a symbol tuple.
;; these are collected so each is unique. any runtime
;; symbol table should be populated with these first.
;; 3) constructed. trees of literals made of constructors
;; (e.g. lists formed with QUOTE), and vectors. each tree
;; is rendered into a single C array where the first value
;; in the array points to the beginning of the top-level
;; object.
(define (emit-constructed o context)
(let ((lits (reverse context.literals))
(nlits (length lits))
(strings (alist/make))
(output '())
(current-index 0)
(symbol-counter 0)
)
;; emit UOHEAD and UITAG macros, special-casing the builtin datatypes
(define (uohead nargs dt variant index)
(match dt variant with
'list 'cons -> "CONS_HEADER"
_ _ -> (format "UOHEAD(" (int nargs) "," (int index) ")")))
(define (uitag dt variant index)
(match dt variant with
'list 'nil -> "TC_NIL"
_ _ -> (format "UITAG(" (int index) ")")))
(define (walk exp)
(match exp with
;; data constructor
(literal:cons dt variant args)
-> (let ((dto (alist/get context.datatypes dt "no such datatype"))
(alt (dto.get variant))
(nargs (length args)))
(if (> nargs 0)
;; constructor with args
(let ((args0 (map walk args))
(addr (+ 1 (length output))))
(PUSH output (uohead nargs dt variant alt.index))
(for-each (lambda (x) (PUSH output x)) args0)
(format "UPTR(" (int current-index) "," (int addr) ")"))
;; nullary constructor - immediate
(uitag dt variant alt.index)))
(literal:vector args)
-> (let ((args0 (map walk args))
(nargs (length args))
(addr (+ 1 (length output))))
(PUSH output (format "(" (int nargs) "<<8)|TC_VECTOR"))
(for-each (lambda (x) (PUSH output x)) args0)
(format "UPTR(" (int current-index) "," (int addr) ")"))
(literal:symbol sym)
-> (let ((index (alist/get context.symbols sym "unknown symbol?")))
(format "UPTR(" (int index) ",1)"))
(literal:string s)
-> (match (alist/lookup strings s) with
(maybe:yes index) -> (format "UPTR0(" (int index) ")")
(maybe:no) -> (error "emit-constructed: lost string"))
_ -> (int->string (encode-immediate exp))
))
(o.dedent) ;; XXX fix this by defaulting to zero indent
(for-range
i nlits
(set! output '())
(set! current-index i)
(let ((lit (nth lits i)))
(match lit with
;; strings are a special case here because they have a non-uniform structure: the existence of
;; the uint32_t <length> field means it's hard for us to put a UPTR in the front.
(literal:string s)
-> (let ((slen (string-length s)))
;; this works because we want strings compared for eq? identity...
(alist/push strings s i)
(o.write (format "pxll_string constructed_" (int i) " = {STRING_HEADER(" (int slen) "), " (int slen) ", \"" (c-string s) "\" };")))
;; there's a temptation to skip the extra pointer at the front, but that would require additional smarts
;; in insn_constructed (as already exist for strings).
;; NOTE: this reference to the string object only works because it comes before the symbol in self.context.constructed.
(literal:symbol s)
-> (begin
(o.write (format "// symbol " (sym s)))
(o.write (format "pxll_int constructed_" (int i)
"[] = {UPTR(" (int i)
",1), SYMBOL_HEADER, UPTR0(" (int (- current-index 1))
"), INTCON(" (int symbol-counter) ")};"))
(set! symbol-counter (+ 1 symbol-counter))
)
_ -> (let ((val (walk (nth lits i)))
(rout (list:cons val (reverse output))))
(o.write (format "pxll_int constructed_" (int i) "[] = {" (join id "," rout) "};")))
)))
(let ((symptrs '()))
(alist/iterate
(lambda (symbol index)
(PUSH symptrs (format "UPTR(" (int index) ",1)")))
context.symbols)
(o.write (format "pxll_int pxll_internal_symbols[] = {(" (int (length symptrs)) "<<8)|TC_VECTOR, " (join id ", " symptrs) "};"))
)
(o.indent)
))
(define c-string-safe?
(char-class
(string->list
"0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~ ")))
;; fix when we get zero-padding format capability...
(define (char->oct-encoding ch)
(let ((in-oct (format (oct (char->ascii ch)))))
(format
(match (string-length in-oct) with
0 -> "000"
1 -> "00"
2 -> "0"
_ -> (error1 "unable to oct-encode character" ch)
)
in-oct)))
(define (c-string s)
(let loop ((r '())
(s (string->list s)))
(match s with
() -> (string-concat (reverse r))
(ch . rest)
-> (loop
(list:cons
(match ch with
#\return -> "\\r"
#\newline -> "\\n"
#\tab -> "\\t"
#\\ -> "\\\\"
#\" -> "\\\""
_ -> (if (c-string-safe? ch)
(char->string ch)
(char->oct-encoding ch)))
r)
rest))))
(define (emit-lookup-field o context)
(cond ((> (length context.records) 0)
(o.write "static int lookup_field (int tag, int label)")
(o.write "{ switch (tag) {")
(for-each
(lambda (pair)
(match pair with
(:pair sig index)
-> (begin (o.write (format " case " (int index) ":"))
(o.write " switch (label) {")
(for-range
i (length sig)
(o.write (format " case "
(int (lookup-label-code (nth sig i) context))
": return " (int i) "; break;")))
(o.write " } break;"))))
context.records)
(o.write "}}"))))