compiler.rkt

#lang typed/racket

(require "types.rkt")
(require "simplifier.rkt")
(require (submod pyramid/types ast))
(require pyramid/ast)
(require pyramid/expander)
(require (submod pyramid/expander macros))
(require pyramid/utils)
(require pyramid/io)
(require pyramid/globals)

(provide compile-translation-unit)

#|
Compilation strategy
* Flow control such as break, continue, or return are implemented by creating and calling continuations.
* Expressions always resolve to a result, and can also have an associated location.
** An rvalue is an expression that is compiled to emit a result
** An lvalue is an expression that is compiled to emit a location
** Some expressions such as constants or non-modifying binary operators are not lvalues
** rvalues and lvalues always fit inside a single machine word, simplifying parameter and return passing.
** Rules for converting expression values to rvalues and lvalues:
*** The rvalue of a machine word is that word. The lvalue is the address where such a word is stored.
*** The rvalue and the lvalue of a struct are both pointers. Ceagle does not attempt to generate local bytestrings.
**** However, the rvalue of a struct allocates and copies into a new struct, so the pointers are not equal.
*** The rvalue of a function is the code pointer for it. An lvalue is the address where such a code pointer is stored.
* Variables are always initialized with an rvalue
* Parameters are always passed as rvalues
* Return values are passed as rvalues

Switch Statements
 1. Compile a list of all case statements bound to this switch
 2. Put them into a table with the constant as key, and a new label as value. default: or breakpoint is the fallback
 3. Generate a (cond) from the table. The condition is equality with the case X and the provided switch value. The action is a jump.
 4. When compiling default: and case: statements, produce a label deterministically-calculated from the currently active switch and its case: argument.
|#

(module typechecker typed/racket
  (require "types.rkt")
  (require (submod pyramid/types common))
  (require/typed racket/hash
    [ hash-union! (-> (HashTable Symbol c-type) (HashTable Symbol c-type) [#:combine/key (-> Symbol c-type c-type c-type)] Void)]
    [ hash-union (-> (HashTable Symbol c-type) (HashTable Symbol c-type) [#:combine/key (-> Symbol c-type c-type c-type)] (HashTable Symbol c-type))]
    )

  (require pyramid/utils)

  (provide (all-defined-out))

  (: *struct-registry* (Parameterof TypeRegistry))
  (define *struct-registry* (make-parameter (make-type-registry)))

  (: *union-registry* (Parameterof TypeRegistry))
  (define *union-registry* (make-parameter (make-type-registry)))

  (: *type-registry* (Parameterof TypeRegistry))
  (define *type-registry* (make-parameter (make-type-registry)))

  (: *variables* (Parameterof variable-table))
  (define *variables* (make-parameter (make-variable-table)))

  (: unsafe-register-type! (-> Symbol c-type c-typespace Void))
  (define (unsafe-register-type! name ty typespace)
    (hash-set! (typespace-registry typespace)
               name
               ty)
    )

  (: register-type! (-> Symbol c-type c-typespace Void))
  (define (register-type! name ty typespace)
    (maybe-register-type! ty)
    (unsafe-register-type! name ty typespace))

  (: register-variable! (-> Symbol c-type Void))
  (define (register-variable! name ty)
    (maybe-register-type! ty)
    (hash-set! (*variables*) name ty))

  (: typespace-registry (-> c-typespace TypeRegistry))
  (define (typespace-registry ty)
    (match ty
      [#f      (*type-registry*)]
      ['struct (*struct-registry*)]
      ['union  (*union-registry*)]
      ))

  (define-syntax-rule (declare-variable-scope xs ...)
    (parameterize ([ *variables* (hash-copy (*variables*)) ])
      xs ...))

  ; register-type! handles typedefs. This handles "struct x { } => struct x;" associations.
  (: maybe-register-type! (-> c-type Void))
  (define (maybe-register-type! ty)
    (match ty
      [(struct c-type-fixed _) (void)]
      [(struct c-type-struct (name _)) (when name (unsafe-register-type! name ty 'struct))]
      [(struct c-type-union (name _)) (when name (unsafe-register-type! name ty 'union))]
      [(struct c-type-alias _) (void)]
      [(struct c-signature (ret args)) (maybe-register-type! ret)
                                       (for ([ arg args])
                                         (maybe-register-type! (c-sigvar-type arg))
                                         )]
      [(struct c-type-void _) (void)]
      [(struct c-type-pointer (ty)) (maybe-register-type! ty)]
      ))

  (: resolve-type (-> c-type c-type))
  (define (resolve-type ty)
    (match ty
      [(struct c-type-alias (name typespace)) (resolve-type (hash-ref (typespace-registry typespace)
                                                                      name
                                                                      (λ () (error "resolve-type: Unknown type" name typespace))))]
      [_ ty]
      ))
  (: type-field-table (-> c-type FieldTable))
  (define (type-field-table ty)
    (match (resolve-type ty)
      [(struct c-type-fixed _) (make-field-table)]
      [(struct c-type-alias _) (error "type-field-table: Unexpected case" ty)]
      [(struct c-type-struct (_ fs)) (struct-fields->field-table fs)]
      [(struct c-type-pointer _) (make-field-table)]
      [(struct c-type-union (_ fs)) (union-fields->field-table fs)]
      [x (error "type-field-table: Unknown case" x)]
      ))

  (: union-fields->field-table (-> c-type-struct-fields FieldTable))
  (define (union-fields->field-table fs)
    (define ret (make-field-table))
    (define size (fields-max-size fs))
    (for ([ f fs ])
      (match (c-type-struct-field-name f)
        [#f (error "union-fields->field-table: Nested anonymous unions not supported" f)]
        [(? symbol? name) (hash-set! ret name (c-field-info 0 (c-type-struct-field-type f)))]
        ))
    ret)

  (: struct-fields->field-table (-> c-type-struct-fields FieldTable))
  (define (struct-fields->field-table fs)
    (define ret (make-field-table))
    (define os 0)
    (for ([ f fs ])
      (let* ([ ty (c-type-struct-field-type f) ]
             [ name (c-type-struct-field-name f) ]
             [ size (type-size ty)]
             [ fi (c-field-info os ty)])
        (match* (name ty)
          [(#f (struct c-type-union (_ fs2)))
           (for ([ f2 fs2])
             (let* ([ name2 (c-type-struct-field-name f2) ]
                    [ ty2 (c-type-struct-field-type f2)]
                    [ fi2 (c-field-info os ty2)])
               (if name2
                   (hash-set! ret name2 fi2)
                   (error "struct-fields->field-table: Nested anonymous unions not supported" f2))))]
          [(#f _) (error "struct-fields->field-table: Only unions can be unnamed struct memebers" f)]
          [((? symbol? name) _)  (hash-set! ret name fi)]
          )
        (set! os (+ os size))
        ))
    ret)

  (: expression-type (-> c-expression c-type))
  (define (expression-type exp)
    (define macro-type (c-signature t-uint '()))
    (match exp
      [(struct c-const (_ signed?)) (if signed? t-int t-uint)]
      [(struct c-variable (name)) (hash-ref (*variables*) name (λ () (error "expression-type: Unknown variable" name (*variables*))))]
      [(struct c-ternary (_ cons _)) (expression-type cons)]
      [(struct c-binop (_ left _)) (expression-type left)]
      [(struct c-unop ('* exp))
       (match (expression-type exp)
         [(struct c-type-pointer (x)) x]
         [ty (error "expression-type: Attempted to dereference a non-pointer" ty exp)])]
      [(struct c-unop (_ exp)) (expression-type exp)]
      [(struct c-function-call (func _))
       (match (expression-type func)
         [(struct c-signature (ret _)) ret]
         [_ (error "expression-type: Unknown function call" func)]
         )]
      [(struct c-field-access (source name))
       (define src-ty (expression-type source))
       (define ft (type-field-table src-ty))
       (define fi (hash-ref ft name (λ () (error "expression-type: No field with name found" source name ft))))
       (c-field-info-type fi)
       ]
      [(struct c-cast (ty _)) ty]
      [(struct c-sizeof (x)) t-size]
      [(struct c-array-access (arr idx)) (match (expression-type arr)
                                           [(struct c-type-pointer (ty)) ty]
                                           [ty (error "expression-type: An array should be a pointer" ty)])]
      [(struct c-expression-sequence (exps)) (expression-type (last exps))]
      [(struct c-expression-array (exps)) (expression-type (first exps))]
      [_ (error "expression-type: Unhandled case" exp)]
      ))

  (: pointer-expression? (-> c-expression Boolean))
  (define (pointer-expression? x)
    (c-type-pointer? (expression-type x)))

  ; Size in bytes of the type
  (: type-size (-> c-type Size))
  (define (type-size x)
    (match (resolve-type x)
      [(struct c-type-fixed (_ bytes)) 32 ];bytes]
      [(struct c-type-struct (_ fields)) (for/sum : Size ([ field fields ])
                                           (type-size (c-type-struct-field-type field)))]
      [(struct c-signature _) 32]
      [(struct c-type-pointer _) 32]
      [(struct c-type-union (_ fields)) (fields-max-size fields)]
      [(struct c-signature _) 32 ]
      [_ (error "type-size: Unknown case" x)]
      ))

  (: pad-size (-> Size Size))
  (define (pad-size x)
    (+ x (modulo x 32)))

  (: fields-max-size (-> c-type-struct-fields Size))
  (define (fields-max-size fields)
    (apply max (map (λ ([x : c-type-struct-field ])
                      (type-size (c-type-struct-field-type x)))
                    fields)))

  )
(require 'typechecker)

(module* test racket
  (require rackunit)
  (require "types.rkt")
  (require (submod ".."))
  (require (submod ".." typechecker))
  (check-equal? (expression-type (c-binop '<< (c-const 1 #t) (c-const 1 #t))) t-int)
  (check-equal? (expression-type (c-binop '<< (c-const 1 #f) (c-const 1 #t))) t-uint)
  (parameterize ([ *variables* (make-variable-table) ])
    (register-variable! 'f (c-signature t-uint '()))
    (check-equal? (expression-type (c-function-call (c-variable 'f) '())) t-uint)
    )
  )

(: *switch-counter* (Parameterof Counter))
(define *switch-counter* (make-parameter 0))

(: *switch-base* (Parameterof Counter))
(define *switch-base* (make-parameter 0))

(: *current-function* (Parameterof Symbol))
(define *current-function* (make-parameter 'TOPLEVEL))

(: compile-translation-unit (-> c-unit Boolean Pyramid))
(define (compile-translation-unit x execute?)
  (verbose-section "Ceagle AST" VERBOSITY-LOW
                   (pretty-print x))
  (set! x (simplify x))
  (destruct c-unit x)
  (verbose-section "Ceagle Simplified AST" VERBOSITY-MEDIUM
                   (pretty-print x))
  (register-builtins!)
  (let ([ decls     (pyr-begin (map compile-declaration x-decls)) ]
        [ call-main (c-function-call (c-variable 'main) (list))])
    (quasiquote-pyramid
     `(begin (require ceagle "builtins.pmd")
             ,decls
             ,(if execute?
                  (quasiquote-pyramid `(%#-box ,(compile-expression call-main 'rvalue)))
                  (pyr-begin null))))))

(: compile-declaration (-> c-declaration Pyramid))
(define (compile-declaration x)
  (match x
    [(struct c-decl-var     _) (compile-decl-var     x)]
    [(struct c-decl-type    _) (compile-decl-type    x)]
    [(struct c-decl-func    _) (compile-decl-func    x)]
    [_                         (error "compile-decl: unknown case" x)]))

(: compile-decl-var (-> c-decl-var Pyramid))
(define (compile-decl-var x)
  (destruct c-decl-var x)
  (register-variable! x-name x-type)
  (make-macro-application #`(#,(variable-definer x-type) #,x-name #,(shrink-pyramid
                                                                     (if x-init
                                                                         (compile-expression x-init 'rvalue)
                                                                         (compile-default-initializer x-type)))))
  )

(: variable-definer (-> c-type PyramidQ))
(define (variable-definer ty)
  (match (resolve-type ty)
    [(struct c-type-fixed   _) #'%c-define-fixnum]
    [(struct c-type-struct  _) #'%c-define-struct]
    [(struct c-type-pointer _) #'%c-define-pointer]
    [(struct c-type-union   _) #'%c-define-union]
    [ty (error "variable_definer: Unhandled case" ty)]))

(: compile-default-initializer (-> c-type Pyramid))
(define (compile-default-initializer ty)
  (match (resolve-type ty)
    [(struct c-type-fixed  _) (expand-pyramid #'(unbox 0))]
    [(struct c-type-struct _) (expand-pyramid #`(%c-allocate-struct #,(type-size ty)))]
    [(struct c-type-union  _) (expand-pyramid #`(%c-allocate-struct #,(type-size ty)))]
    ))

(: compile-decl-type (-> c-decl-type Pyramid))
(define (compile-decl-type x)
  (destruct c-decl-type x)
  (register-type! x-name x-type #f)
  (pyr-begin (list)))

(: compile-decl-func (-> c-decl-func Pyramid))
(define (compile-decl-func x)
  (destruct c-decl-func x)
  (destruct c-signature x-sig)
  (: sigvar-init (-> c-sigvar VariableName))
  (define (sigvar-init v) (symbol-append (c-sigvar-name v)
                                         '-init))
  (: vars VariableNames)
  (define vars (map sigvar-init x-sig-args))
  (register-variable! x-name x-sig)
  (declare-variable-scope
   (define args (for/list : Pyramids ([ arg x-sig-args ])
                  (define arg-name (c-sigvar-name arg))
                  (define arg-type (c-sigvar-type arg))
                  (register-variable! arg-name arg-type)
                  (make-macro-application #`(#,(variable-definer arg-type) #,arg-name #,(sigvar-init arg)))))
   (pyr-definition x-name
                   (pyr-lambda vars
                               (quasiquote-pyramid
                                `(begin ,@args
                                        ,(with-returnpoint
                                           (compile-statement x-body))))))))

(: compile-statement (-> c-statement Pyramid))
(define (compile-statement x)
  (match x
    [(? c-labeled?)              (compile-labeled         x)]
    [(? c-labeled-case?)         (compile-labeled-case    x)]
    [(? c-labeled-default?)      (compile-labeled-default x)]
    [(? c-expression-statement?) (compile-expression  (c-expression-statement-exp x) 'rvalue)]
    [(? c-switch?)               (compile-switch      x)]
    [(? c-if?)                   (compile-if          x)]
    [(? c-for?)                  (compile-for         x)]
    [(? c-while?)                (compile-while       x)]
    [(? c-do-while?)             (compile-do-while    x)]
    [(? c-goto?)                 (compile-goto        x)]
    [(? c-block?)                (compile-block       x)]
    [(? c-return?)               (compile-return      x)]
    [(? c-break?)                (compile-break       x)]
    [(? c-continue?)             (compile-continue    x)]
    [(? c-declaration?)          (compile-declaration x)]
    [_                           (error "compile-statement: Unknown case" x)]))

(: compile-labeled (-> c-labeled Pyramid))
(define (compile-labeled x)
  (destruct c-labeled x)
  (expand-pyramid
   #`(begin (asm (label (quote #,x-name)))
            #,(shrink-pyramid (compile-statement x-body)))))

(: compile-labeled-statement (-> label c-statement Pyramid))
(define (compile-labeled-statement lbl stmt)
  (expand-pyramid
   #`(begin (asm (label (quote #,(label-name lbl))))
           #,(shrink-pyramid (compile-statement stmt))))
  )

(: compile-labeled-case (-> c-labeled-case Pyramid))
(define (compile-labeled-case x)
  (compile-labeled-statement (switch-case-label x)
                             (c-labeled-case-body x))
  )

(: compile-labeled-default (-> c-labeled-default Pyramid))
(define (compile-labeled-default x)
  (compile-labeled-statement (switch-default-label x)
                             (c-labeled-default-body x))
  )

(: compile-expression (-> c-expression c-value-type Pyramid))
(define (compile-expression x val-ty)
  (match x
    [(? c-const?)         (compile-const         x val-ty)]
    [(? c-variable?)      (compile-variable      x val-ty)]
    [(? c-ternary?)       (compile-ternary       x val-ty)]
    [(? c-binop?)         (compile-binop         x val-ty)]
    [(? c-unop?)          (compile-unop          x val-ty)]
    [(? c-function-call?) (compile-function-call x val-ty)]
    [(? c-field-access?)  (compile-field-access  x val-ty)]
    [(? c-cast?)          (compile-cast          x val-ty)]
    [(? c-array-access?)  (compile-array-access  x val-ty)]
    [(? c-expression-sequence?) (compile-expression-sequence x val-ty)]
    [(? c-expression-array?) (compile-expression-array x val-ty)]
    [_                    (error "compile-expression: Unknown case" x)]))

(: compile-const (-> c-const c-value-type Pyramid))
(define (compile-const x val-ty)
  (restrict-output-range
   (expression-type x)
   (match val-ty
     ['lvalue (error "compile-const: A constant cannot be an lvalue" x)]
     ['rvalue (if (string? (c-const-value x))
                  (expand-pyramid #`(box   #,(c-const-value x)))
                  (expand-pyramid #`(unbox #,(c-const-value x))))]
     )))

(: compile-variable (-> c-variable c-value-type Pyramid))
(define (compile-variable x val-ty)
  (define exp (pyr-variable (c-variable-name x)))
  (define exp-ty (resolve-type (expression-type x)))
  (define size (expand-pyramid #`(unbox #,(type-size exp-ty))))
  (match* (val-ty exp-ty)
    [('rvalue (struct c-signature   _))  exp]
    [('rvalue (struct c-type-fixed  _)) (quasiquote-pyramid `(%c-word-read ,exp))]
    [('rvalue (struct c-type-struct _))
     (quasiquote-pyramid
      `(let ([ copy (%c-allocate-struct ,size)])
         (%c-struct-copy ,size ,exp copy)))]
    [('rvalue (struct c-type-pointer _)) (quasiquote-pyramid `(%c-word-read ,exp))]
    [('rvalue (struct c-type-union   _))
     (quasiquote-pyramid
      `(let ([ copy (%c-allocate-struct ,size)])
         (%c-struct-copy ,size ,exp copy)))]
    [('lvalue (struct c-type-fixed  _)) exp]
    [('lvalue (struct c-type-struct _)) exp]
    [('lvalue (struct c-type-union  _)) exp]
    [('lvalue (struct c-type-pointer (ptr-ty))) exp]
    [(_ _)    (error "compile-variable: Unhandled case" val-ty exp-ty)]
    ))

(: compile-ternary (-> c-ternary c-value-type Pyramid))
(define (compile-ternary x val-ty)
  (destruct c-ternary x)
  (pyr-if (compile-expression x-pred        'rvalue)
          (compile-expression x-consequent  val-ty)
          (compile-expression x-alternative val-ty)))

(: compile-binop (-> c-binop c-value-type Pyramid))
(define (compile-binop x val-ty)
  (destruct c-binop x)
  (define vop (assign-op->value-op x-op))
  (define ty (resolve-type (expression-type x)))
  (define (struct? _) (c-type-struct? ty))
  (restrict-output-range
   ty
   (match x-op
     ['+ (compile-binop (c-binop 'raw+
                                 (c-binop '* x-left
                                          (c-const (type-increment-size (expression-type x-left)) #t))
                                 (c-binop '* x-right
                                          (c-const (type-increment-size (expression-type x-right)) #t)))
                        'rvalue)]
     ['- (compile-binop (c-binop 'raw-
                                 (c-binop '* x-left
                                          (c-const (type-increment-size (expression-type x-left)) #t))
                                 (c-binop '* x-right
                                          (c-const (type-increment-size (expression-type x-right)) #t)))
                        'rvalue)]
     [(and '= (? struct?)) (quasiquote-pyramid
                            `(%#-memcpy ,(compile-expression x-left 'lvalue)
                                        ,(compile-expression x-right 'rvalue)
                                        ,(expand-pyramid #`(unbox #,(type-size (expression-type x-left))))))]
     [ _
       (let* ([ signed? (expression-signed? x) ]
              [ rvalue-exp (quasiquote-pyramid
                            `(,(op->builtin x-op signed?)
                              ,(compile-expression x-left 'rvalue)
                              ,(compile-expression x-right 'rvalue)))])
         (if vop ; vop is only true if x-op was an assignment
             (quasiquote-pyramid
              `(let ([ value ,(compile-binop (c-binop vop x-left x-right) 'rvalue)])
                 (begin (%c-word-write! ,(compile-expression x-left 'lvalue)
                                        value)
                        value)))
             rvalue-exp))]
     )))

; x+1 on a T pointer increases the word in x by sizeof(T).
(: type-increment-size (-> c-type Size))
(define (type-increment-size ty)
  (match (resolve-type ty)
    [(struct c-type-pointer (ty2)) (type-size ty2)]
    [(struct c-type-fixed _) 1]
    ))

(: compile-unop (-> c-unop c-value-type Pyramid))
(define (compile-unop x val-ty)
  (destruct c-unop x)
  (define rvalue-exp (pyr-application (op->builtin x-op #f)
                                      (list (compile-expression x-exp 'rvalue))
                                      #f))
  (define (wants-old?)
    (match x-op
      ['post++ #t]
      ['post-- #t]
      ['pre++  #f]
      ['pre--  #f]
      ))
  (define ty (expression-type x))
  (restrict-output-range
   ty
   (match x-op
     ['& (compile-expression x-exp 'lvalue)]
     ['* (compile-dereference x-exp val-ty)]
     ['- (compile-expression (c-binop '- (c-const 0 #t) x-exp) val-ty)]
     ['+ (compile-expression x-exp val-ty)]
     ['pre++ (compile-expression (c-binop '+= x-exp (c-const 1 #t)) val-ty)]
     ['pre-- (compile-expression (c-binop '-= x-exp (c-const 1 #t)) val-ty)]
     ['post++
      (assert (equal? val-ty 'rvalue))
      (quasiquote-pyramid
       `(let* ([ old   ,(compile-expression x-exp 'rvalue) ])
          ,(compile-expression (c-binop '+= x-exp (c-const 1 #t)) 'rvalue)
          old))]
     ['post--
      (assert (equal? val-ty 'rvalue))
      (quasiquote-pyramid
       `(let* ([ old   ,(compile-expression x-exp 'rvalue) ])
          ,(compile-expression (c-binop '-= x-exp (c-const 1 #t)) 'rvalue)
          old))]
     [_ rvalue-exp]
     )))

(: compile-dereference (-> c-expression c-value-type Pyramid))
(define (compile-dereference exp ty)
  (define rval (compile-expression exp 'rvalue))
  (assert exp pointer-expression?)
  (match ty
    ['lvalue rval]
    ['rvalue (quasiquote-pyramid `(%c-word-opdereference ,rval))]
    ))

(: compile-function-call (-> c-function-call c-value-type Pyramid))
(define (compile-function-call x val-ty)
  (destruct c-function-call x)
  (match val-ty
    ['lvalue (error "compile-function-call: Function calls cannot be lvalues" x)]
    ['rvalue (quasiquote-pyramid
              `(,(compile-expression x-func 'rvalue)
                ,@(map (λ ([ x : c-expression ])
                         (compile-expression x 'rvalue))
                       x-args)))]
    ))

(: compile-field-access (-> c-field-access c-value-type Pyramid))
(define (compile-field-access x val-ty)
  (destruct c-field-access x)
  (define ty (expression-type x-source))
  (define field-table (type-field-table ty))
  (define info (hash-ref field-table x-name (λ () (error "compile-field-access: Field not found" (resolve-type ty) x field-table))))
  (destruct c-field-info info)
  (define ptr-exp
    (quasiquote-pyramid
     `(%c-struct-field ,(compile-expression x-source 'lvalue)
                       ,(pyr-const info-offset #f)
                       ,(pyr-const (type-size info-type) #f))))

  (match val-ty
    ['lvalue ptr-exp]
    ['rvalue (quasiquote-pyramid `(%c-word-read ,ptr-exp))]
    ))

(: compile-cast (-> c-cast c-value-type Pyramid))
(define (compile-cast x val-ty)
  (destruct c-cast x)
  (compile-expression x-exp val-ty)
  )

(: compile-array-access (-> c-array-access c-value-type Pyramid))
(define (compile-array-access x val-ty)
  (destruct c-array-access x)
  (assert (equal? val-ty 'rvalue)) ; TODO: lvalue
  (quasiquote-pyramid
   `(%#-mem-read ,(compile-expression x-array 'rvalue) ,(compile-expression x-index 'rvalue)))
  )

(: compile-expression-sequence (-> c-expression-sequence c-value-type Pyramid))
(define (compile-expression-sequence x val-ty)
  (destruct c-expression-sequence x)
  (quasiquote-pyramid
   `(begin ,@(map (λ ([ exp : c-expression ])
                    (compile-expression exp val-ty))
                  x-exps)))
  )

(: compile-expression-array (-> c-expression-array c-value-type Pyramid))
(define (compile-expression-array x val-ty)
  (destruct c-expression-array x)
  (assert (equal? val-ty 'rvalue))
  (quasiquote-pyramid
   `(%#-mem-alloc-init (%#-* %#-WORD ,(pyr-const (length x-exps) #f))
                       ,@(map (λ ([ exp : c-expression ])
                                (compile-expression exp 'rvalue))
                              x-exps)))
  )

; See "Switch Statements"
(: compile-switch      (-> c-switch      Pyramid))
(define (compile-switch sw)
  (with-switch-base
    (define-values (cases default) (switch-labels sw))
    (define label-after (make-label 'switch-after))
    (: jump (-> label Pyramid))
    (define (jump lbl) (expand-pyramid #`(asm (goto (label (quote #,(label-name lbl)))))))
    (: make-condition-entry (-> c-labeled-case Pyramid))
    (define (make-condition-entry c)
      (define cond-expr (c-labeled-case-expected c))
      (quasiquote-pyramid
       `((,(compile-expression cond-expr 'rvalue)) ,(jump (switch-case-label c))))
      )
    (: make-jump-table (-> c-labeled-cases (Maybe c-labeled-default) Pyramids))
    (define (make-jump-table cases default)
      (append (map make-condition-entry cases)
              (list (quasiquote-pyramid `(else ,(if default
                                                    (jump (switch-default-label default))
                                                    (expand-pyramid #'(break 0))))))))
    (with-breakpoint
      (quasiquote-pyramid
       `(begin (%c-case ,(compile-expression (c-switch-actual sw) 'rvalue)
                        ,@(make-jump-table cases default))
               ,(compile-statement (c-switch-body sw)))))
    ))

(: switch-labels (-> c-switch (Values c-labeled-cases (Maybe c-labeled-default))))
(define (switch-labels x)
  (: cases c-labeled-cases)
  (define cases null)
  (: default (Maybe c-labeled-default))
  (define default #f)
  (: register-case! (-> c-labeled-case Void))
  (define (register-case! x)    (set! cases (cons x cases)))
  (: register-default! (-> c-labeled-default Void))
  (define (register-default! x) (set! default x))
  (for ([ y (c-stmt-descendants x #:stop-on? c-switch?)])
    (match y
      [(struct c-labeled-case (expected body)) (register-case! y)]
      [(struct c-labeled-default (body))       (register-default! y)]
      [_ (void)]
      ))
  (values cases default)
  )

(: cvalue->symbol (-> CValue Symbol))
(define (cvalue->symbol cv)
  (match cv
    [(? integer?) (string->symbol (format "~v" cv))]
    ))

(: switch-case-label (-> c-labeled-case label))
(define (switch-case-label c)
  (destruct c-labeled-case c)
  (match c-expected
    [(struct c-const (cv _))
     (label (symbol-append 'switch-case-
                           (cvalue->symbol (*switch-base*))
                           (cvalue->symbol cv)))]
    [(struct c-variable (name))
     (label (symbol-append 'switch-case-
                           (cvalue->symbol (*switch-base*))
                           name))]
    ))

(: switch-default-label (-> c-labeled-default label))
(define (switch-default-label x)
  (destruct c-labeled-default x)
  (label (symbol-append 'switch-default-
                        (cvalue->symbol (*switch-base*))))
  )

; (: with-switch-base (-> (-> Pyramid) Pyramid))
(define-syntax-rule (with-switch-base body ...)
  (parameterize ([ *switch-base* (tick-counter! *switch-counter*)])
    body ...))

(: c-stmt-children (-> c-statement c-statements))
(define (c-stmt-children x)
  (match x
    [(struct c-labeled (_ st)) (list st)]
    [(struct c-labeled-case (_ st)) (list st)]
    [(struct c-labeled-default (st)) (list st)]
    [(struct c-expression-statement _) (list)]
    [(struct c-switch (_ st)) (list st)]
    [(struct c-if (_ st1 st2)) (list st1 st2)]
    [(struct c-for (_ _ _ st)) (list st)]
    [(struct c-while (_ st)) (list st)]
    [(struct c-do-while (_ st)) (list st)]
    [(struct c-goto _) (list)]
    [(struct c-block (sts)) sts]
    [(struct c-return _) (list)]
    [(struct c-break _) (list)]
    [(struct c-continue _) (list)]
    ))

(: c-stmt-descendants (-> c-statement [#:stop-on? (-> c-statement Boolean)] c-statements))
(define (c-stmt-descendants x #:stop-on? [ stop-on? (λ (x) #f)])
  (cons x (apply append (map (λ ([ st : c-statement ])
                               (if (stop-on? st)
                                   (list)
                                   (c-stmt-descendants st #:stop-on? stop-on?)))
                             (c-stmt-children x)))))

(: compile-if          (-> c-if          Pyramid))
(define (compile-if x)
  (destruct c-if x)
  (pyr-if (compile-expression x-pred 'rvalue)
          (compile-statement  x-consequent)
          (compile-statement  x-alternative)
          ))

(: compile-for         (-> c-for         Pyramid))
(define (compile-for x)
  (destruct c-for x)
  (define init (map compile-declaration x-init))
  (define post (if x-post
                   (compile-expression x-post 'rvalue)
                   (expand-pyramid #'(begin))))
  (define pred (if x-pred
                   (compile-expression x-pred 'rvalue)
                   (expand-pyramid #'#t)))

  (with-breakpoint
    (quasiquote-pyramid
     `(begin ,@init
             (%c-loop-forever
              ,(with-continuepoint
                 (quasiquote-pyramid
                  `(if ,pred
                       (begin ,(compile-statement x-body)
                              ,post
                              (continue 0))
                       (break 0)))))))))

(: compile-while       (-> c-while       Pyramid))
(define (compile-while x)
  (destruct c-while x)
  (compile-for (c-for '() x-pred #f x-body)))

(: compile-do-while    (-> c-do-while    Pyramid))
(define (compile-do-while x)
  (destruct c-do-while x)
  (with-breakpoint
    (quasiquote-pyramid
     `(%c-loop-forever
       ,(with-continuepoint
          (quasiquote-pyramid
           `(begin ,(compile-statement x-body)
                   (if ,(compile-expression x-pred 'rvalue)
                       (continue 0)
                       (break #f)))))))))

(: compile-goto        (-> c-goto        Pyramid))
(define (compile-goto x)
  (compile-jump (c-goto-target x)))

(: compile-block       (-> c-block       Pyramid))
(define (compile-block x)
  ; TODO: This likely doesn't handle gotos between blocks, since the lambda creates a new continuation frame.
  (quasiquote-pyramid
   `((λ ()
       ,(compile-c-sequence (c-block-body x))
       ))))

(: compile-return      (-> c-return      Pyramid))
(define (compile-return x)
  (destruct c-return x)
  (match x-val
    [ #f (quasiquote-pyramid `(return 0))]
    [ (? c-expression? val)  (quasiquote-pyramid `(return ,(compile-expression val 'rvalue)))]
    ))

(: compile-break       (-> c-break       Pyramid))
(define (compile-break x)
  (expand-pyramid #'(break #f)))

(: compile-continue    (-> c-continue    Pyramid))
(define (compile-continue x)
  (expand-pyramid #'(continue #f)))

(: compile-c-sequence (-> c-statements Pyramid))
(define (compile-c-sequence xs)
  (match (map compile-statement xs)
    [(? null?) (pyr-begin (list))]
    [(list y ) y]
    [ys        (pyr-begin ys)]))

(: compile-jump (-> Symbol Pyramid))
(define (compile-jump x)
  (expand-pyramid
   #`(asm (goto (label (quote #,x))))))

;; (: make-c-label (-> Symbol c-label))
;; (define (make-c-label name)
;;   (c-labeled (make-label-name name)))

(: with-escapepoint (-> Symbol Pyramid Pyramid))
(define (with-escapepoint name exp)
  (expand-pyramid #`(call/cc (λ (#,name) #,(shrink-pyramid exp)))))

(: with-returnpoint (-> Pyramid Pyramid))
(define (with-returnpoint exp)
  (with-escapepoint 'return exp))

(: with-continuepoint (-> Pyramid Pyramid))
(define (with-continuepoint exp)
  (with-escapepoint 'continue exp))

(: with-breakpoint (-> Pyramid Pyramid))
(define (with-breakpoint exp)
  (with-escapepoint 'break exp))

(: assign-op->value-op (-> Symbol (U #f Symbol)))
(define (assign-op->value-op op)
  (match op
    ['<<= '<<]
    ['>>= '>>]
    ['+=  '+]
    ['-=  '-]
    ['*=  '*]
    ['/=  '/]
    ['%=  '%]
    ['\|\|= '\|\|]
    ['\|= '\|]
    ['^=  '^]
    ['&&= '&&]
    ['&=  '&]
    ['=   'right]
    [_    #f]
    ))

(: op->builtin (-> Symbol Boolean Pyramid))
(define (op->builtin op signed?)
  (define rvalue-op
    (match op
      [(? assign-op->value-op x) x]
      ['<  (if signed? 's<  'u<)]
      ['>  (if signed? 's>  'u>)]
      ['<= (if signed? 's<= 'u<=)]
      ['>= (if signed? 's>= 'u>=)]
      [_ op]))
  (pyr-variable (symbol-append '%c-word-op rvalue-op))
  )

(: assign-ops (Setof Symbol))
;(define assign-ops (set))
(define assign-ops (apply set '(<<= >>= += -= *= /= %= \|\|= \|= ^= &&= &= =)))

(: wants-lvalue? (-> Symbol Boolean))
(define (wants-lvalue? op)
  (set-member? assign-ops op))

(: register-builtins! (-> Void))
(define (register-builtins!)
  (register-variable! '__builtin_set_test_result          (c-signature (c-type-void) (list (c-sigvar 'expected t-int))))
  (register-variable! '__builtin_ctzll                    (c-signature t-int (list (c-sigvar 'x t-int))))
  (register-variable! '__builtin_clzll                    (c-signature t-int (list (c-sigvar 'x t-int))))
  (register-variable! '__builtin_bswap64                  (c-signature t-int (list (c-sigvar 'x t-int))))
  (register-variable! '__builtin_trap                     (c-signature (c-type-void) (list (c-sigvar 'x t-int))))

  (register-variable! '__builtin_print_word               (c-signature (c-type-void) (list (c-sigvar 'x t-int))))
  (register-variable! '__builtin_print_string             (c-signature (c-type-void) (list (c-sigvar 'x t-int))))
  (register-variable! '__builtin_print_char               (c-signature (c-type-void) (list (c-sigvar 'x t-char))))
  (register-variable! '__builtin_set_max_iterations       (c-signature t-int (list (c-sigvar 'x t-int))))
  (register-variable! '__builtin_set_max_simulator_memory (c-signature t-int (list (c-sigvar 'x t-int))))
  )

(: type-signed? (-> c-type Boolean))
(define (type-signed? x)
  (match (resolve-type x)
    [(struct c-type-fixed (signed? _)) signed?]
    [(struct c-type-pointer _) #f]
    [y (error "type-signed?: Unable to determine signedness of type" y)]
    ))

(: expression-signed? (-> c-expression Boolean))
(define (expression-signed? x)
  (type-signed? (expression-type x))
  )

; A 64-bit integer needs to be restricted to the 64 bits after a 256-bit addition or similar is performed.
(: restrict-output-range (-> c-type Pyramid Pyramid))
(define (restrict-output-range ty x)
  (match (resolve-type ty)
    [(struct c-type-fixed (_ 32)) x]
    [(struct c-type-fixed (signed? sz)) (make-macro-application
                                         #`(%c-restrict-bytes #,(shrink-pyramid x) (unbox #,sz) #,signed?))]
    [_ x]
    ))