Permalink
Cannot retrieve contributors at this time
| #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] | |
| )) |