Permalink
Cannot retrieve contributors at this time
Name already in use
A tag already exists with the provided branch name. Many Git commands accept both tag and branch names, so creating this branch may cause unexpected behavior. Are you sure you want to create this branch?
ceagle/compiler.rkt
Go to fileThis commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
885 lines (794 sloc)
34.6 KB
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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] | |
)) |