<commit_before>;; -*- Mode: Irken -*-

(include "self/nodes.scm")

(datatype tag
  (:bare int)
  (:uobj int)
  )

;; ================================================================================
;; here's an interesting idea: why not attach the solved type to *every* insn?
;; actually, we pretty much *have* to do that in order to get a working C interface.
;; ================================================================================

;; RTL instructions
(datatype insn
  (:return int)                                                 ;; return register
  (:literal literal cont)                                       ;; <value> <k>
  (:litcon int symbol cont)                                     ;; <index> <value> <k>
  (:cexp type type string (list int) cont)                      ;; <sig> <solved-type> <template> <args> <k>
  (:test int insn insn cont)                                    ;; <reg> <then> <else> <k>
  (:testcexp (list int) type string insn insn cont)             ;; <regs> <sig> <template> <then> <else> <k>
  (:jump int int)                                               ;; <reg> <target>
  (:close symbol insn cont)                                     ;; <name> <body> <k>
  (:varref int int cont)                                        ;; <depth> <index> <k>
  (:varset int int int cont)                                    ;; <depth> <index> <reg> <k>
  (:new-env int bool cont)	                                ;; <size> <top?> <k>
  (:alloc tag int cont)                                         ;; <tag> <size> <k>
  (:store int int int int cont)                                 ;; <offset> <arg> <tuple> <i> <k>
  (:invoke (maybe symbol) int int cont)                         ;; <name> <closure> <args> <k>
  (:tail (maybe symbol) int int)                                ;; <name> <closure> <args>
  (:trcall int symbol (list int))                               ;; <depth> <name> <args>
  (:push int cont)                                              ;; <env>
  (:pop int cont)                                               ;; <result>
  (:primop symbol sexp type (list int) cont)                    ;; <name> <params> <args> <k>
  (:move int int cont)                                          ;; <var> <src> <k>
  (:fatbar int insn insn cont)                                  ;; <label> <alt0> <alt1> <k>
  (:fail int int)                                               ;; <label> <npop>
  (:nvcase int symbol (list symbol) (list insn) (maybe insn) cont)      ;; <reg> <dt> <tags> <alts> <ealt> <k>
  (:pvcase int (list symbol) (list int) (list insn) (maybe insn) cont)  ;; <reg> <tags> <arities> <ealt> <k>
  )

;; continuation
;; XXX wonder if this would make more sense as a record?
(datatype cont
  (:k int (list int) insn) ;; <target-register> <free-registers> <code>
  (:nil)
  )

;; we use several kinds of environment 'ribs' during this phase
(datatype cpsenv
  (:nil) 				;; empty
  (:rib (list symbol) cpsenv)		;; variables
  (:reg symbol int cpsenv)		;; variables-in-registers
  (:fat int cpsenv)			;; fatbar context
  )

(define lenv-top?
  (cpsenv:nil) -> #t
  _ -> #f
  )

(define (make-register-allocator)
  (let ((max-reg -1))
    (define (allocate free)
      (let loop ((i 0))
	(if (member? i free =)
	    (loop (+ i 1))
	    (begin (set! max-reg (max i max-reg)) i))))
    (define (get-max) max-reg)
    {alloc=allocate get-max=get-max}
    ))

;; perhaps name these cont/xxx could be confusing.
(define k/free
  (cont:k _ free _)   -> free
  (cont:nil) -> (error "k/free"))

(define k/target
  (cont:k target _ _) -> target
  (cont:nil) -> (error "k/target"))

(define add-free-regs
  (cont:k target free k) regs -> (cont:k target (append free regs) k)
  (cont:nil) _		      -> (error "add-free-regs"))

(define (compile exp context)

  (let ((current-funs '(top)))

    (define (set-flag! flag)
      (vars-set-flag! context (car current-funs) flag))

    (define (cont free generator)
      (let ((reg (context.regalloc.alloc free)))
	(cont:k reg free (generator reg))))

    (define (dead free k)
      (cont:k -1 free k))

    (define (compile tail? exp lenv k)

      ;; override continuation when in tail position
      (if tail?
	  (set! k (cont (k/free k) gen-return)))
  
      (match exp.t with
	(node:literal lit)		-> (c-literal lit exp.id k)
	(node:sequence)			-> (c-sequence tail? exp.subs lenv k)
	(node:if)			-> (c-conditional tail? exp lenv k)
	(node:function name formals)	-> (c-function name formals exp.id (car exp.subs) lenv k)
	(node:varref name)		-> (c-varref name lenv k)
	(node:varset name)		-> (c-varset name (car exp.subs) lenv k)
	(node:cexp gens sig template)	-> (c-cexp sig template exp lenv k)
	(node:call)			-> (c-call tail? exp lenv k)
	(node:primapp name params)	-> (c-primapp tail? name params exp lenv k)
	(node:nvcase 'nil tags arities) -> (c-pvcase tail? tags arities exp.subs lenv k)
	(node:nvcase dt tags arities)	-> (c-nvcase tail? dt tags exp.subs lenv k)
	(node:fix formals)		-> (c-let-splat tail? formals exp.subs lenv k)
	(node:let formals)		-> (if (safe-for-let-reg exp formals context)
					       (c-let-reg tail? formals exp.subs lenv k)
					       (c-let-splat tail? formals exp.subs lenv k))
	(node:subst _ _)		-> (impossible)
	)
      )

    (define (add-literal lit)
      (let ((index (length context.literals)))
	(PUSH context.literals lit)
	index))

    ;; inlining often causes literals to be copied all over the place.
    ;;   we can detect this because their node id's are the same.  So keep
    ;;   a map from id->litindex so we can reference via litcon.

    (define (get-literal-index lit id)
      (match (tree/member context.literal-ids < id) with
	(maybe:yes v) -> v
	(maybe:no)
	-> (let ((index (add-literal lit)))
	     (set! context.literal-ids
		   (tree/insert context.literal-ids < id index))
	     index)))

    (define (get-symbol-index sym)
      (match (alist/lookup context.symbols sym) with
	(maybe:yes index) -> index
	(maybe:no)
	-> (let ((string-index (add-literal (literal:string (symbol->string sym))))
		 (symbol-index (add-literal (literal:symbol sym))))
	     (alist/push context.symbols sym symbol-index)
	     symbol-index)))

    ;; scan through a literal for symbols and strings, make sure they're recorded as well.
    (define scan-literals
      () -> 0
      (hd . tl) -> (begin
		     (match hd with
		       (literal:symbol sym)    -> (get-symbol-index sym)
		       (literal:string s)      -> (add-literal hd)
		       (literal:cons _ _ args) -> (scan-literals args)
		       (literal:vector args)   -> (scan-literals args)
		       _ -> 0)
		     (scan-literals tl)))

    (define (c-literal lit id k)
      (match lit with
	;; non-immediate literals are 'constructed' and referenced by index.
	(literal:symbol s)	-> (insn:litcon (get-symbol-index s) 'symbol k)
	(literal:string s)	-> (insn:litcon (get-literal-index lit id) 'string k)
	(literal:vector args)	-> (begin
				     (scan-literals args)
				     (insn:litcon (get-literal-index lit id) 'vector k))
	;; problem: any literal without args should be encoded as an
	;;   immediate, and not show up in 'constructed'.  I think it
	;;   can be done like this:
	;; (literal:cons x y ()) -> (insn:literal lit k)
	(literal:cons 'bool s _) -> (insn:literal lit k)
	(literal:cons _ _ args) -> (begin
				     (scan-literals args)
				     (insn:litcon (get-literal-index lit id) 'constructor k))
	;; immediate literals are done 'inline'.
	_ -> (insn:literal lit k)))

    (define (c-sequence tail? nodes lenv k)
      (match nodes with
	()	     -> (error "empty sequence?")
	(exp)	     -> (compile tail? exp lenv k)
	(exp . exps) -> (compile #f exp lenv (dead (k/free k) (c-sequence tail? exps lenv k)))
	))

    ;; XXX consider redoing with fatbar?
    (define (c-conditional tail? exp lenv k)
      (let ((target (k/target k))
	    (free (k/free k)))
	(match exp.subs with
	  (test then else)
	  -> (match test.t with
	       (node:cexp _ sig template)
	       -> (c-simple-conditional tail? test then else sig template lenv k)
	       _ -> (compile
		     #f test lenv
		     (cont free
			   (lambda (reg)
			     (insn:test
			      reg
			      (compile tail? then lenv (cont free (lambda (reg) (insn:jump reg target))))
			      (compile tail? else lenv (cont free (lambda (reg) (insn:jump reg target))))
			      k))
			   )))
	  _ -> (error1 "c-conditional" exp)
	  )))

    (define (c-simple-conditional tail? test then else sig template lenv k)
      (let ((free (k/free k))
	    (target (k/target k)))
	(define (finish regs)
	  ;; <regs> <sig> <template> <then> <else> <k>
	  (insn:testcexp
	   regs sig template
	   (compile tail? then lenv (cont free (lambda (reg) (insn:jump reg target))))
	   (compile tail? else lenv (cont free (lambda (reg) (insn:jump reg target))))
	   k))
	(collect-primargs test.subs lenv k finish)))

    (define extend-lenv
      () lenv -> lenv ;; don't extend with an empty rib
      fs lenv -> (cpsenv:rib fs lenv)
      )

    (define (c-function name formals id body lenv k)
      (set-flag! VFLAG-ALLOCATES)
      (PUSH current-funs name)
      (let ((r
	     (insn:close
	      name
	      (compile #t
		       body
		       (extend-lenv formals lenv)
		       (cont '() gen-return))
	      k)))
	(pop current-funs)
	r))

    (define search-rib
      name0 _ ()		  -> (maybe:no)
      name0 i (name1 . names) -> (if (eq? name0 name1)
				     (maybe:yes i)
				     (search-rib name0 (+ i 1) names)))

    ;; Note: only 'real' environment ribs increase lexical depth.
    (define lexical-address
      name _ (cpsenv:nil)	       -> (error1 "unbound variable" name)
      name d (cpsenv:rib names lenv)   -> (match (search-rib name 0 names) with
					    (maybe:yes i) -> (if (eq? lenv (cpsenv:nil))
								 (:top i)
								 (:pair d i))
					    (maybe:no)    -> (lexical-address name (+ d 1) lenv))
      name d (cpsenv:fat _ lenv)       -> (lexical-address name d lenv)
      name d (cpsenv:reg name0 r lenv) -> (if (eq? name name0)
					      (:reg r)
					      (lexical-address name d lenv))
      )

    (define (c-varref name lenv k)
      (match (lexical-address name 0 lenv) with
	(:reg r) -> (insn:move r -1 k)
	(:pair depth index) -> (insn:varref depth index k)
	(:top index) -> (insn:varref -1 index k)
	))

    (define (c-varset name exp lenv k)
      (let ((kfun
	     (match (lexical-address name 0 lenv) with
	       (:pair depth index)
	       -> (lambda (reg) (insn:varset depth index reg k))
	       (:top index)
	       -> (lambda (reg) (insn:varset -1 index reg k))
	       (:reg index)
	       -> (lambda (reg) (insn:move reg index k))
	       )))
	(compile #f exp lenv (cont (k/free k) kfun))))

    (define (c-primapp tail? name params exp lenv k)
      (let ((args exp.subs))
	(match name with
	  '%fail    -> (c-fail tail? lenv k)
	  '%fatbar  -> (c-fatbar tail? args lenv k)
	  '%dtcon   -> (begin (if (> (length args) 0)
				 (set-flag! VFLAG-ALLOCATES))
			     (c-primargs args name params exp.type lenv k))
	  '%vcon    -> (c-vcon params args lenv k)
	  '%rextend -> (c-record-literal exp lenv k)
	  '%raccess -> (let ((arg0 (nth args 0))
			     (sig (get-record-sig-sexp arg0.type)))
			 (c-primargs args '%record-get
				     (sexp params sig) ;; (field sig)
				     exp.type
				     lenv k))
	  '%rset    -> (let ((arg0 (nth args 0))
			     (sig (get-record-sig-sexp arg0.type)))
			 (c-primargs args '%record-set
				     (sexp params sig) ;; (field sig)
				     exp.type
				     lenv k))
	  '%cset    -> (let ((val (nth args 2))
			     (tval val.type)
			     (buffer (nth args 0)))
			 (match buffer.type with
			   (type:pred 'buffer (tbase) _)
			   -> (let ((cast-type (arrow tbase (LIST tval))))
				;; we need both types in order to cast correctly
				(c-primargs args name params cast-type lenv k))
			   _ -> (impossible)))
	  ;; do-nothing prim used to verify exception types
	  '%exn-raise  -> (compile tail? (first args) lenv k)
	  ;; note: discards first argument...
	  '%exn-handle -> (compile tail? (second args) lenv k)
	  _ -> (c-primargs args name params exp.type lenv k))))
   
    (define (c-cexp sig template exp lenv k)
      ;;(print-string (format "c-cexp: sig = " (type-repr sig) " solved type = " (type-repr exp.type) "\n"))
      (collect-primargs exp.subs lenv k
			(lambda (regs)
			  (insn:cexp sig exp.type template regs k))))

    ;; collect-primargs is used by primops, simple-conditional, and tr-call.
    ;;   in order to avoid the needless consumption of registers, we re-arrange
    ;;   the eval order of these args - by placing the complex args first.

    (define (collect-primargs args lenv k ck)
      (let ((args0 (map-range
		       i (length args)
		       (:pair (nth args i) i)))
	    (args1 (sort (lambda (a b)
			   (match a b with
			     (:pair arg_a _) (:pair arg_b _)
			     -> (> arg_a.size arg_b.size)))
			 args0))
	    (perm (map pair->second args1))
	    (args2 (map pair->first args1)))
	(collect-primargs* args2 '() perm lenv k ck)))

    (define (collect-primargs* args regs perm lenv k ck)
      (match args with
	()        -> (let ((regs (reverse regs))
			   ;; undo the permutation of the arg regs
			   (perm-regs
			    (map-range
				i (length perm)
				(nth regs (index-eq i perm)))))
		       (ck perm-regs))
	(hd . tl) -> (compile #f hd lenv
			      (cont (append (k/free k) regs)
				    (lambda (reg) (collect-primargs* tl (cons reg regs) perm lenv k ck))))
	))

    (define (c-primargs args op parm type lenv k)
      (collect-primargs args lenv k
			(lambda (regs) (insn:primop op parm type regs k))))

    (define (safe-for-let-reg exp names context)
      (and (node-get-flag exp NFLAG-LEAF)
	   (< (length names) 5)
	   (not (some?
		 (lambda (name)
		   (vars-get-flag context name VFLAG-ESCAPES))
		 names))))

    (define (safe-for-tr-call exp fun)
      (match fun with
	(node:varref name)
	-> (and (node-get-flag exp NFLAG-RECURSIVE)
		(not (vars-get-flag context (car current-funs) VFLAG-ESCAPES)))
	_ -> #f))

    (define (c-trcall depth name args lenv k)
      ;; NOTE: this means tail-calls do not have a guaranteed argument eval order!
      (collect-primargs args lenv k
			(lambda (regs) (insn:trcall depth name regs))))

    (define (c-call tail? exp lenv k)
      (match exp.subs with
	(fun . args)
	-> (if (and tail? (safe-for-tr-call exp fun.t))
	       (let ((name (varref->name fun.t)))
		 (match (lexical-address name 0 lenv) with
		   (:reg _) -> (error "c-call function in register?")
		   (:pair depth index) -> (c-trcall depth name args lenv k)
		   (:top index) -> (c-trcall -1 name args lenv k)
		   ))
	       (let ((gen-invoke (if tail? gen-tail gen-invoke))
		     (name (match fun.t with
			     (node:varref name)
			     -> (if (vars-get-flag context name VFLAG-FUNCTION)
				    (maybe:yes name)
				    (maybe:no))
			     _ -> (maybe:no))))
		 (define (make-call args-reg)
		   (compile #f fun lenv (cont (cons args-reg (k/free k))
					      (lambda (closure-reg) (gen-invoke name closure-reg args-reg k)))))
		 (if (> (length args) 0)
		     (compile-args args lenv (cont (k/free k) make-call))
		     (make-call -1))))
	() -> (error "c-call: no function?")
	))

    (define (compile-args args lenv k)
      (set-flag! VFLAG-ALLOCATES)<commit_msg>c-call(): trcall needs the correct lexical depth of the recursive function lexical-address(): return <depth> in (:top ...)<commit_after>;; -*- Mode: Irken -*-

(include "self/nodes.scm")

(datatype tag
  (:bare int)
  (:uobj int)
  )

;; ================================================================================
;; here's an interesting idea: why not attach the solved type to *every* insn?
;; actually, we pretty much *have* to do that in order to get a working C interface.
;; ================================================================================

;; RTL instructions
(datatype insn
  (:return int)                                                 ;; return register
  (:literal literal cont)                                       ;; <value> <k>
  (:litcon int symbol cont)                                     ;; <index> <value> <k>
  (:cexp type type string (list int) cont)                      ;; <sig> <solved-type> <template> <args> <k>
  (:test int insn insn cont)                                    ;; <reg> <then> <else> <k>
  (:testcexp (list int) type string insn insn cont)             ;; <regs> <sig> <template> <then> <else> <k>
  (:jump int int)                                               ;; <reg> <target>
  (:close symbol insn cont)                                     ;; <name> <body> <k>
  (:varref int int cont)                                        ;; <depth> <index> <k>
  (:varset int int int cont)                                    ;; <depth> <index> <reg> <k>
  (:new-env int bool cont)	                                ;; <size> <top?> <k>
  (:alloc tag int cont)                                         ;; <tag> <size> <k>
  (:store int int int int cont)                                 ;; <offset> <arg> <tuple> <i> <k>
  (:invoke (maybe symbol) int int cont)                         ;; <name> <closure> <args> <k>
  (:tail (maybe symbol) int int)                                ;; <name> <closure> <args>
  (:trcall int symbol (list int))                               ;; <depth> <name> <args>
  (:push int cont)                                              ;; <env>
  (:pop int cont)                                               ;; <result>
  (:primop symbol sexp type (list int) cont)                    ;; <name> <params> <args> <k>
  (:move int int cont)                                          ;; <var> <src> <k>
  (:fatbar int insn insn cont)                                  ;; <label> <alt0> <alt1> <k>
  (:fail int int)                                               ;; <label> <npop>
  (:nvcase int symbol (list symbol) (list insn) (maybe insn) cont)      ;; <reg> <dt> <tags> <alts> <ealt> <k>
  (:pvcase int (list symbol) (list int) (list insn) (maybe insn) cont)  ;; <reg> <tags> <arities> <ealt> <k>
  )

;; continuation
;; XXX wonder if this would make more sense as a record?
(datatype cont
  (:k int (list int) insn) ;; <target-register> <free-registers> <code>
  (:nil)
  )

;; we use several kinds of environment 'ribs' during this phase
(datatype cpsenv
  (:nil) 				;; empty
  (:rib (list symbol) cpsenv)		;; variables
  (:reg symbol int cpsenv)		;; variables-in-registers
  (:fat int cpsenv)			;; fatbar context
  )

(define lenv-top?
  (cpsenv:nil) -> #t
  _ -> #f
  )

(define (make-register-allocator)
  (let ((max-reg -1))
    (define (allocate free)
      (let loop ((i 0))
	(if (member? i free =)
	    (loop (+ i 1))
	    (begin (set! max-reg (max i max-reg)) i))))
    (define (get-max) max-reg)
    {alloc=allocate get-max=get-max}
    ))

;; perhaps name these cont/xxx could be confusing.
(define k/free
  (cont:k _ free _)   -> free
  (cont:nil) -> (error "k/free"))

(define k/target
  (cont:k target _ _) -> target
  (cont:nil) -> (error "k/target"))

(define add-free-regs
  (cont:k target free k) regs -> (cont:k target (append free regs) k)
  (cont:nil) _		      -> (error "add-free-regs"))

(define (compile exp context)

  (let ((current-funs '(top)))

    (define (set-flag! flag)
      (vars-set-flag! context (car current-funs) flag))

    (define (cont free generator)
      (let ((reg (context.regalloc.alloc free)))
	(cont:k reg free (generator reg))))

    (define (dead free k)
      (cont:k -1 free k))

    (define (compile tail? exp lenv k)

      ;; override continuation when in tail position
      (if tail?
	  (set! k (cont (k/free k) gen-return)))
  
      (match exp.t with
	(node:literal lit)		-> (c-literal lit exp.id k)
	(node:sequence)			-> (c-sequence tail? exp.subs lenv k)
	(node:if)			-> (c-conditional tail? exp lenv k)
	(node:function name formals)	-> (c-function name formals exp.id (car exp.subs) lenv k)
	(node:varref name)		-> (c-varref name lenv k)
	(node:varset name)		-> (c-varset name (car exp.subs) lenv k)
	(node:cexp gens sig template)	-> (c-cexp sig template exp lenv k)
	(node:call)			-> (c-call tail? exp lenv k)
	(node:primapp name params)	-> (c-primapp tail? name params exp lenv k)
	(node:nvcase 'nil tags arities) -> (c-pvcase tail? tags arities exp.subs lenv k)
	(node:nvcase dt tags arities)	-> (c-nvcase tail? dt tags exp.subs lenv k)
	(node:fix formals)		-> (c-let-splat tail? formals exp.subs lenv k)
	(node:let formals)		-> (if (safe-for-let-reg exp formals context)
					       (c-let-reg tail? formals exp.subs lenv k)
					       (c-let-splat tail? formals exp.subs lenv k))
	(node:subst _ _)		-> (impossible)
	)
      )

    (define (add-literal lit)
      (let ((index (length context.literals)))
	(PUSH context.literals lit)
	index))

    ;; inlining often causes literals to be copied all over the place.
    ;;   we can detect this because their node id's are the same.  So keep
    ;;   a map from id->litindex so we can reference via litcon.

    (define (get-literal-index lit id)
      (match (tree/member context.literal-ids < id) with
	(maybe:yes v) -> v
	(maybe:no)
	-> (let ((index (add-literal lit)))
	     (set! context.literal-ids
		   (tree/insert context.literal-ids < id index))
	     index)))

    (define (get-symbol-index sym)
      (match (alist/lookup context.symbols sym) with
	(maybe:yes index) -> index
	(maybe:no)
	-> (let ((string-index (add-literal (literal:string (symbol->string sym))))
		 (symbol-index (add-literal (literal:symbol sym))))
	     (alist/push context.symbols sym symbol-index)
	     symbol-index)))

    ;; scan through a literal for symbols and strings, make sure they're recorded as well.
    (define scan-literals
      () -> 0
      (hd . tl) -> (begin
		     (match hd with
		       (literal:symbol sym)    -> (get-symbol-index sym)
		       (literal:string s)      -> (add-literal hd)
		       (literal:cons _ _ args) -> (scan-literals args)
		       (literal:vector args)   -> (scan-literals args)
		       _ -> 0)
		     (scan-literals tl)))

    (define (c-literal lit id k)
      (match lit with
	;; non-immediate literals are 'constructed' and referenced by index.
	(literal:symbol s)	-> (insn:litcon (get-symbol-index s) 'symbol k)
	(literal:string s)	-> (insn:litcon (get-literal-index lit id) 'string k)
	(literal:vector args)	-> (begin
				     (scan-literals args)
				     (insn:litcon (get-literal-index lit id) 'vector k))
	;; problem: any literal without args should be encoded as an
	;;   immediate, and not show up in 'constructed'.  I think it
	;;   can be done like this:
	;; (literal:cons x y ()) -> (insn:literal lit k)
	(literal:cons 'bool s _) -> (insn:literal lit k)
	(literal:cons _ _ args) -> (begin
				     (scan-literals args)
				     (insn:litcon (get-literal-index lit id) 'constructor k))
	;; immediate literals are done 'inline'.
	_ -> (insn:literal lit k)))

    (define (c-sequence tail? nodes lenv k)
      (match nodes with
	()	     -> (error "empty sequence?")
	(exp)	     -> (compile tail? exp lenv k)
	(exp . exps) -> (compile #f exp lenv (dead (k/free k) (c-sequence tail? exps lenv k)))
	))

    ;; XXX consider redoing with fatbar?
    (define (c-conditional tail? exp lenv k)
      (let ((target (k/target k))
	    (free (k/free k)))
	(match exp.subs with
	  (test then else)
	  -> (match test.t with
	       (node:cexp _ sig template)
	       -> (c-simple-conditional tail? test then else sig template lenv k)
	       _ -> (compile
		     #f test lenv
		     (cont free
			   (lambda (reg)
			     (insn:test
			      reg
			      (compile tail? then lenv (cont free (lambda (reg) (insn:jump reg target))))
			      (compile tail? else lenv (cont free (lambda (reg) (insn:jump reg target))))
			      k))
			   )))
	  _ -> (error1 "c-conditional" exp)
	  )))

    (define (c-simple-conditional tail? test then else sig template lenv k)
      (let ((free (k/free k))
	    (target (k/target k)))
	(define (finish regs)
	  ;; <regs> <sig> <template> <then> <else> <k>
	  (insn:testcexp
	   regs sig template
	   (compile tail? then lenv (cont free (lambda (reg) (insn:jump reg target))))
	   (compile tail? else lenv (cont free (lambda (reg) (insn:jump reg target))))
	   k))
	(collect-primargs test.subs lenv k finish)))

    (define extend-lenv
      () lenv -> lenv ;; don't extend with an empty rib
      fs lenv -> (cpsenv:rib fs lenv)
      )

    (define (c-function name formals id body lenv k)
      (set-flag! VFLAG-ALLOCATES)
      (PUSH current-funs name)
      (let ((r
	     (insn:close
	      name
	      (compile #t
		       body
		       (extend-lenv formals lenv)
		       (cont '() gen-return))
	      k)))
	(pop current-funs)
	r))

    (define search-rib
      name0 _ ()		  -> (maybe:no)
      name0 i (name1 . names) -> (if (eq? name0 name1)
				     (maybe:yes i)
				     (search-rib name0 (+ i 1) names)))

    ;; Note: only 'real' environment ribs increase lexical depth.
    (define lexical-address
      name _ (cpsenv:nil)	       -> (error1 "unbound variable" name)
      name d (cpsenv:rib names lenv)   -> (match (search-rib name 0 names) with
					    (maybe:yes i) -> (if (eq? lenv (cpsenv:nil))
								 (:top d i)
								 (:pair d i))
					    (maybe:no)    -> (lexical-address name (+ d 1) lenv))
      name d (cpsenv:fat _ lenv)       -> (lexical-address name d lenv)
      name d (cpsenv:reg name0 r lenv) -> (if (eq? name name0)
					      (:reg r)
					      (lexical-address name d lenv))
      )

    (define (c-varref name lenv k)
      (match (lexical-address name 0 lenv) with
	(:reg r) -> (insn:move r -1 k)
	(:pair depth index) -> (insn:varref depth index k)
	(:top _ index) -> (insn:varref -1 index k)
	))

    (define (c-varset name exp lenv k)
      (let ((kfun
	     (match (lexical-address name 0 lenv) with
	       (:pair depth index)
	       -> (lambda (reg) (insn:varset depth index reg k))
	       (:top _ index)
	       -> (lambda (reg) (insn:varset -1 index reg k))
	       (:reg index)
	       -> (lambda (reg) (insn:move reg index k))
	       )))
	(compile #f exp lenv (cont (k/free k) kfun))))

    (define (c-primapp tail? name params exp lenv k)
      (let ((args exp.subs))
	(match name with
	  '%fail    -> (c-fail tail? lenv k)
	  '%fatbar  -> (c-fatbar tail? args lenv k)
	  '%dtcon   -> (begin (if (> (length args) 0)
				 (set-flag! VFLAG-ALLOCATES))
			     (c-primargs args name params exp.type lenv k))
	  '%vcon    -> (c-vcon params args lenv k)
	  '%rextend -> (c-record-literal exp lenv k)
	  '%raccess -> (let ((arg0 (nth args 0))
			     (sig (get-record-sig-sexp arg0.type)))
			 (c-primargs args '%record-get
				     (sexp params sig) ;; (field sig)
				     exp.type
				     lenv k))
	  '%rset    -> (let ((arg0 (nth args 0))
			     (sig (get-record-sig-sexp arg0.type)))
			 (c-primargs args '%record-set
				     (sexp params sig) ;; (field sig)
				     exp.type
				     lenv k))
	  '%cset    -> (let ((val (nth args 2))
			     (tval val.type)
			     (buffer (nth args 0)))
			 (match buffer.type with
			   (type:pred 'buffer (tbase) _)
			   -> (let ((cast-type (arrow tbase (LIST tval))))
				;; we need both types in order to cast correctly
				(c-primargs args name params cast-type lenv k))
			   _ -> (impossible)))
	  ;; do-nothing prim used to verify exception types
	  '%exn-raise  -> (compile tail? (first args) lenv k)
	  ;; note: discards first argument...
	  '%exn-handle -> (compile tail? (second args) lenv k)
	  _ -> (c-primargs args name params exp.type lenv k))))
   
    (define (c-cexp sig template exp lenv k)
      ;;(print-string (format "c-cexp: sig = " (type-repr sig) " solved type = " (type-repr exp.type) "\n"))
      (collect-primargs exp.subs lenv k
			(lambda (regs)
			  (insn:cexp sig exp.type template regs k))))

    ;; collect-primargs is used by primops, simple-conditional, and tr-call.
    ;;   in order to avoid the needless consumption of registers, we re-arrange
    ;;   the eval order of these args - by placing the complex args first.

    (define (collect-primargs args lenv k ck)
      (let ((args0 (map-range
		       i (length args)
		       (:pair (nth args i) i)))
	    (args1 (sort (lambda (a b)
			   (match a b with
			     (:pair arg_a _) (:pair arg_b _)
			     -> (> arg_a.size arg_b.size)))
			 args0))
	    (perm (map pair->second args1))
	    (args2 (map pair->first args1)))
	(collect-primargs* args2 '() perm lenv k ck)))

    (define (collect-primargs* args regs perm lenv k ck)
      (match args with
	()        -> (let ((regs (reverse regs))
			   ;; undo the permutation of the arg regs
			   (perm-regs
			    (map-range
				i (length perm)
				(nth regs (index-eq i perm)))))
		       (ck perm-regs))
	(hd . tl) -> (compile #f hd lenv
			      (cont (append (k/free k) regs)
				    (lambda (reg) (collect-primargs* tl (cons reg regs) perm lenv k ck))))
	))

    (define (c-primargs args op parm type lenv k)
      (collect-primargs args lenv k
			(lambda (regs) (insn:primop op parm type regs k))))

    (define (safe-for-let-reg exp names context)
      (and (node-get-flag exp NFLAG-LEAF)
	   (< (length names) 5)
	   (not (some?
		 (lambda (name)
		   (vars-get-flag context name VFLAG-ESCAPES))
		 names))))

    (define (safe-for-tr-call exp fun)
      (match fun with
	(node:varref name)
	-> (and (node-get-flag exp NFLAG-RECURSIVE)
		(not (vars-get-flag context (car current-funs) VFLAG-ESCAPES)))
	_ -> #f))

    (define (c-trcall depth name args lenv k)
      ;; NOTE: this means tail-calls do not have a guaranteed argument eval order!
      (collect-primargs args lenv k
			(lambda (regs) (insn:trcall depth name regs))))

    (define (c-call tail? exp lenv k)
      (match exp.subs with
	(fun . args)
	-> (if (and tail? (safe-for-tr-call exp fun.t))
	       (let ((name (varref->name fun.t)))
		 (match (lexical-address name 0 lenv) with
		   (:reg _) -> (error "c-call function in register?")
		   (:pair depth _) -> (c-trcall depth name args lenv k)
		   (:top depth _) -> (c-trcall depth name args lenv k)
		   ))
	       (let ((gen-invoke (if tail? gen-tail gen-invoke))
		     (name (match fun.t with
			     (node:varref name)
			     -> (if (vars-get-flag context name VFLAG-FUNCTION)
				    (maybe:yes name)
				    (maybe:no))
			     _ -> (maybe:no))))
		 (define (make-call args-reg)
		   (compile #f fun lenv (cont (cons args-reg (k/free k))
					      (lambda (closure-reg) (gen-invoke name closure-reg args-reg k)))))
		 (if (> (length args) 0)
		     (compile-args args lenv (cont (k/free k) make-call))
		     (make-call -1))))
	() -> (error "c-call: no function?")
	))

    (define (compile-args args lenv k)
      (set-flag! VFLAG-ALLOCATES)
{'fraction_non_alphanumeric': 0.15529511621833378, 'fraction_numerical': 0.0030360407417080178, 'mean_word_length': 2.2019441831295077, 'pattern_counts': {'":': 0, '<': 186, '<?xml version=': 0, '>': 372, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 54, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '858702', 'n_tokens_mistral': 11213, 'n_tokens_neox': 10178, 'n_words': 3405}