compile-push-rvalue := λctx e offset . (tail(
(local e1)
(local e2)
(match (typecheck-slot( (typecheck-lookup e) Cons )) (
()
( (Cons( lt rt )) (
(match e (
()
( (App( le re )) (tail(
(set e1 (compile-push-rvalue( ctx le offset )))
(set e2 (compile-push-rvalue( ctx re (expr::get-offset e1) )))
(expr::chain( e1 e2 ))
)))
( u (fail (UnexpectedRvalue e)))
))
))
( lt (tail(
(set e1 (compile-expr-strict( ctx e offset Used )))
(match (typecheck-slot( (expr::get-type e1) StackVariable )) (
()
( StackVariable e1 )
( _ (tail(
()
(fragment-apply( ctx 'push lt (() e1) e1 ))
)))
))
)))
))
));
compile-expr-strict := λctx e offset used . (tail(
(assert-typeof( 'compile-expr-strict::ctx ctx Context ))
(assert-typeof( 'compile-expr-strict::e e Or<[Or<[Or<[App,Nil]>,Variable]>,Literal]> ))
(assert-typeof( 'compile-expr-strict::offset offset Atom ))
(assert-typeof( 'compile-expr-strict::used used Atom ))
(local e1)
(local e2)
(local e3)
(local e4)
(local return)
(match used (
()
(Return (tail(
(set e1 (compile-expr-strict( ctx e offset Used )))
(match e (
()
( (App( (App( (Literal ':) re )) rtype )) (
(fragment-apply( ctx 'cdecl::return (typecheck-lookup re) (() e1) e1 ))
))
( re (
(fragment-apply( ctx 'cdecl::return (typecheck-lookup e) (() e1) e1 ))
))
))
)))
(_ (tail(
(set return (match e (
()
( (App( (Lambda( (Variable lname) Nil )) rhs )) (tail(
(local sz)
(set sz (max( 8 (typecheck-sizeof (typecheck-lookup rhs)) )))
(if sz () (
(fail (NoSizeOf (typecheck-lookup rhs)))
))
(set e1 (compile-push-rvalue( ctx rhs offset )))
(set offset (i2s (add( (s2i offset) (inv(s2i sz)) )) ))
(if (eq( sz '0 )) () (
(set e1 (expr::set-unframe( e1 (
\o \s 'unlet \s lname \s '= \s (quote-s rhs) \s ': \s (quote-s(typecheck-lookup rhs)) \n
(expr::get-unframe e1) \t 'add \s '$ sz , \s '%rsp \n
))))
))
(set ctx (context::bind( (expr::get-context e1) lname
(typecheck-ascript( (LocalVariable offset) (typecheck-lookup rhs) ))
)))
(set e1 (expr::set-context( e1 ctx )))
(set e1 (expr::set-offset( e1 offset )))
(set e1 (expr::set-prog( e1 (
\o \s 'let \s lname \s '@ \s offset \n
\o \s 'let \s lname \s '= \s (quote-s rhs) \s ': \s (quote-s(typecheck-lookup rhs)) \n
(expr::get-prog e1)
))))
e1
)))
( (App( (Variable 'maybe-deref) r )) (tail(
(local deref)
(local new-size)
(set new-size (typecheck-sizeof (typecheck-lookup r)))
(match (typecheck-slot( (typecheck-lookup r) Array )) (
()
( (Array( x '? )) (
(if (typecheck-unify-implies( x '? )) () (tail(
(set deref True)
(set new-size (typecheck-sizeof x))
)))
))
))
(if deref (tail(
(set e1 (compile-expr-strict( ctx r offset Used )))
(set e1 (expr::set-type( e1 (typecheck-lookup r) )))
(set e2 (expr::new()))
(set e2 (expr::set-expr( e2 '0 )))
(set e3 (fragment-apply( ctx 'push (Cons( (typecheck-lookup r) (And( Constant Literal )) )) ((() e1) e2) e1 )))
(set e3 (expr::set-type( e3 StackVariable )))
(set offset (i2s(add( (s2i offset) (inv(s2i new-size)) ))))
(set e3 (expr::set-offset( e3 offset )))
(set e3 (expr::set-prog( e3 (
\o \s 'deref \s (quote-s r) \n
(expr::get-prog e3)
))))
e3
)) (
(compile-expr-strict( ctx r offset Used ))
))
)))
( (App( (App( (Variable 'while) cond )) body )) (tail(
(set e1 (compile-expr-strict( ctx cond offset Used )))
(set e2 (compile-expr-strict( ctx body (expr::get-offset e1) Unused )))
(match (expr::get-type e1) (
()
(BranchConditional ())
( et (tail(
(set e1 (expr::set-prog( e1 (
(expr::get-prog e1)
\t 'cmp \s '$0 , \s '%rax \n
))))
(set e1 (expr::set-expr( e1 'jne )))
)))
))
(set e3 (expr::chain( e1 e2 )))
(local label-begin-loop)
(set label-begin-loop (uuid()))
(local label-do-loop)
(set label-do-loop (uuid()))
(local label-end-loop)
(set label-end-loop (uuid()))
(set e3 (expr::set-prog( e3 (
label-begin-loop ': \n
(expr::get-frame e1)
(expr::get-prog e1)
\t (expr::get-expr e1) \s label-do-loop \n
\t 'jmp \s label-end-loop \n
label-do-loop ': \n
(expr::get-frame e2)
(expr::get-prog e2)
(expr::get-unframe e2)
(expr::get-unframe e1)
\t 'jmp \s label-begin-loop \n
label-end-loop ': \n
(expr::get-unframe e1)
))))
(set e3 (expr::set-frame( e3 () )))
(set e3 (expr::set-unframe( e3 () )))
(set e3 (expr::set-offset( e3 offset )))
e3
)))
( (App( (App( (App( (Variable 'if) cond )) t )) f )) (tail(
(local rsp-offset)
(set rsp-offset (i2s(add( (s2i offset) (s2i '-8) ))))
(set e1 (compile-expr-strict( ctx cond rsp-offset Used )))
(set e2 (compile-expr-strict( (expr::get-context e1) t (expr::get-offset e1) Used )))
(set e3 (compile-expr-strict( (expr::get-context e1) f (expr::get-offset e1) Used )))
(match (expr::get-type e1) (
()
(BranchConditional ())
( _ (tail(
(set e1 (expr::set-prog( e1 (
(expr::get-prog e1)
\t 'cmp \s '$0 , \s '%rax \n
))))
(set e1 (expr::set-expr( e1 'jne )))
)))
))
(local end-offset)
(set end-offset (expr::get-offset e2))
(set e4 e1)
(local label-true-branch)
(set label-true-branch (uuid()))
(local label-false-branch)
(set label-false-branch (uuid()))
(local label-end)
(set label-end (uuid()))
(set e4 (expr::set-prog( e4 (
\t 'push \s '%rbp \n
(expr::get-frame e1)
(expr::get-prog e1)
\t (expr::get-expr e1) \s label-true-branch \n
(expr::get-frame e3)
(expr::get-prog e3)
(expr::get-unframe e3)
\t 'jmp \s label-end \n
label-true-branch ': \n
(expr::get-frame e2)
(expr::get-prog e2)
label-end ': \n
\t 'mov \s rsp-offset \[ '%rbp \] , \s '%rsp \n
\t 'add \s '$ end-offset , \s '%rsp \n
))))
(set e4 (expr::set-context( e4 (expr::get-context e2) )))
(set e4 (expr::set-offset( e4 end-offset )))
(set e4 (expr::set-frame( e4 () )))
(set e4 (expr::set-unframe( e4 (
(expr::get-unframe e1)
(expr::get-unframe e2)
(\t 'add \s '$8 , \s '%rsp \n)
))))
e4
)))
( (App( (Variable 'label) (Variable label-name) )) (
(match (get-strict-function( ctx label-name Label )) (
()
( (Label( lid )) (tail(
(set e2 (expr::new()))
(set e2 (expr::set-prog( e2 ( lid ': \n ) )))
(set e2 (expr::set-context( e2 ctx )))
(set e2 (expr::set-offset( e2 offset )))
e2
)))
( u (ExpectedLabel u))
))
))
( (App( (App( (Variable 'set) lhs )) rhs )) (tail(
(assert-eq( 'compile-expr-strict::set (head lhs) Variable ))
(match (get-strict-function( ctx (tail lhs) (typecheck-lookup rhs))) (
()
( (LocalVariable( sv-offset )) (tail(
(set e1 (compile-expr-strict( ctx rhs offset Used )))
(set e1 (expr::set-type( e1 (typecheck-lookup rhs) )))
(set e2 (expr::new()))
(set e2 (expr::set-expr( e2 sv-offset )))
(set e2 (expr::set-context( e2 ctx )))
(set e2 (expr::set-offset( e2 offset )))
(set e2 (expr::set-type( e2 (typecheck-lookup lhs) )))
(set e3 (fragment-apply( ctx 'mov (Cons( (typecheck-lookup rhs) LocalVariable )) ((() e1) e2) e2 )))
(set e3 (expr::set-prog( e3 (
\o \s 'set \s 'local \s (quote-s lhs) \s '@ \s sv-offset \n
(expr::get-prog e3)
))))
)))
( (GlobalVariable( uid )) (tail(
(set e1 (compile-expr-strict( ctx rhs offset Used )))
(set e1 (expr::set-type( e1 (typecheck-lookup rhs) )))
(set e2 (expr::new()))
(set e2 (expr::set-expr( e2 uid )))
(set e2 (expr::set-context( e2 ctx )))
(set e2 (expr::set-offset( e2 offset )))
(set e2 (expr::set-type( e2 (typecheck-lookup lhs) )))
(set e3 (fragment-apply( ctx 'mov (Cons( (typecheck-lookup rhs) GlobalVariable )) ((() e1) e2) e2 )))
)))
( u (fail( UnexpectedAssignmentLhs lhs u )))
))
e3
)))
( (App( (App( (Literal :) (Literal lval) )) ltype )) (tail(
(set ltype (typecheck-infer-type-compound ltype))
(if (typecheck-unify-args( String ltype )) (tail(
(local uid)
(set uid (strict-declare-cstring( lval )))
(set e1 (expr::set-expr( (expr::new ()) uid )))
)) (
(match lval (
()
(True (set e1 (expr::set-expr( (expr::new ()) '1 ))))
(False (set e1 (expr::set-expr( (expr::new ()) '0 ))))
('\\t (set e1 (expr::set-expr( (expr::new ()) '9 ))))
('\\n (set e1 (expr::set-expr( (expr::new ()) '10 ))))
('\\s (set e1 (expr::set-expr( (expr::new ()) '32 ))))
('\\o (set e1 (expr::set-expr( (expr::new ()) '35 ))))
('\\` (set e1 (expr::set-expr( (expr::new ()) '39 ))))
('\\[ (set e1 (expr::set-expr( (expr::new ()) '40 ))))
('\\] (set e1 (expr::set-expr( (expr::new ()) '41 ))))
('\\: (set e1 (expr::set-expr( (expr::new ()) '59 ))))
(_ (set e1 (expr::set-expr( (expr::new ()) lval ))))
))
))
(set e1 (expr::set-context( e1 ctx )))
(set e1 (expr::set-offset( e1 offset )))
e1
)))
( (App( (Variable 'sizeof) (Literal ltype) )) (tail(
(set ltype (parse-type ltype))
(set e1 (expr::set-expr( (expr::new ()) (typecheck-sizeof ltype) )))
(set e1 (expr::set-context( e1 ctx )))
(set e1 (expr::set-offset( e1 offset )))
(set e1 (expr::set-type( e1 ltype )))
e1
)))
( (Literal lval) (tail(
(if (typecheck-unify-args( String (typecheck-lookup e) )) (tail(
(local uid)
(set uid (strict-declare-cstring( lval )))
(set e1 (expr::set-expr( (expr::new ()) uid )))
)) (
(match lval (
()
(True (set e1 (expr::set-expr( (expr::new ()) '1 ))))
(False (set e1 (expr::set-expr( (expr::new ()) '0 ))))
('\\t (set e1 (expr::set-expr( (expr::new ()) '9 ))))
('\\n (set e1 (expr::set-expr( (expr::new ()) '10 ))))
('\\s (set e1 (expr::set-expr( (expr::new ()) '32 ))))
('\\o (set e1 (expr::set-expr( (expr::new ()) '35 ))))
('\\` (set e1 (expr::set-expr( (expr::new ()) '39 ))))
('\\[ (set e1 (expr::set-expr( (expr::new ()) '40 ))))
('\\] (set e1 (expr::set-expr( (expr::new ()) '41 ))))
('\\: (set e1 (expr::set-expr( (expr::new ()) '59 ))))
(_ (set e1 (expr::set-expr( (expr::new ()) lval ))))
))
))
(set e1 (expr::set-context( e1 ctx )))
(set e1 (expr::set-offset( e1 offset )))
e1
)))
( (App( (App( (Literal ':) lval )) ltype )) (tail(
(set e1 (compile-expr-strict( ctx lval offset Used )))
(set e1 (expr::set-type( e1 (typecheck-lookup e) )))
e1
)))
( (App( (App( (Variable 'as) lval )) ltype )) (tail(
(set e1 (compile-expr-strict( ctx lval offset Used )))
(set e1 (expr::set-type( e1 (typecheck-lookup e) )))
e1
)))
( (App( (Variable 'tail) (App( l r )) )) (tail(
(set e1 (compile-expr-strict( ctx l offset Unused )))
(set e2 (compile-expr-strict( (expr::get-context e1) r (expr::get-offset e1) Used )))
(set e2 (expr::set-frame( e2 ( (expr::get-frame e1) (expr::get-frame e2) ))))
(set e2 (expr::set-unframe( e2 ( (expr::get-unframe e1) (expr::get-unframe e2) ))))
(set e2 (expr::set-text( e2 ( (expr::get-text e1) (expr::get-text e2) ))))
(set e2 (expr::set-data( e2 ( (expr::get-data e1) (expr::get-data e2) ))))
(set e2 (expr::set-prog( e2 ( (expr::get-prog e1) (expr::get-prog e2) ))))
e2
)))
( (App ((Variable 'gensym-label) (Variable arg))) (tail(
(set ctx (context::bind( ctx arg
(typecheck-ascript( (Label( (uuid()) )) Label ))
)))
(set e1 (expr::set-context( (expr::new()) ctx )))
(set e1 (expr::set-offset( e1 offset )))
e1
)))
( Nil (tail(
(set e1 (expr::new()) )
(set e1 (expr::set-context( e1 ctx )))
(set e1 (expr::set-offset( e1 offset )))
e1
)))
( (Variable v) (tail(
(set e1 (fragment-get-local( ctx v offset )))
(set e1 (expr::set-type( e1 (typecheck-lookup e) )))
e1
)))
( (App (l r)) (tail(
(local result)
(set result (match (typecheck-slot( (typecheck-lookup l) '-> )) (
()
( ('-> _) (match l (
()
( (Variable fname) (tail(
(set e1 (stack-call( ctx fname r offset )))
(set e1 (expr::set-type( e1 (typecheck-lookup e) )))
e1
)))
( (Literal tag) (tail(
(set e1 (compile-push-rvalue( ctx r offset )))
(set e2 (fragment-apply( ctx 'push (And( (typecheck-lookup e) DontChain)) (() e1) e1 )))
(local sz)
(set sz (typecheck-sizeof(typecheck-lookup e)))
(set offset (expr::get-offset e2))
(set offset (i2s(add( (inv(s2i( sz ))) (s2i offset) ))))
(set e2 (expr::set-type( e2 StackVariable )))
(set e2 (expr::set-offset( e2 offset )))
e2
)))
( u (tail(
(fail (ComplexFunctionConjugatesNotSupportedYet e))
)))
)))
( _ (
(if (eq( used Used )) (
(fail( Raw Cons Cells Are Not Permitted In Strict Mode \n e ))
) (tail(
(set e1 (compile-expr-strict( ctx l offset Unused )))
(set e2 (compile-expr-strict( (expr::get-context e1) r (expr::get-offset e1) Used )))
(set e2 (expr::set-frame( e2 ( (expr::get-frame e1) (expr::get-frame e2) ))))
(set e2 (expr::set-unframe( e2 ( (expr::get-unframe e1) (expr::get-unframe e2) ))))
(set e2 (expr::set-text( e2 ( (expr::get-text e1) (expr::get-text e2) ))))
(set e2 (expr::set-data( e2 ( (expr::get-data e1) (expr::get-data e2) ))))
(set e2 (expr::set-prog( e2 ( (expr::get-prog e1) (expr::get-prog e2) ))))
e2
)))
))
)))
result
)))
( _ (fail (TODO CompileStrict e)))
)))
return
)))
))
));
get-strict-function := λctx v arg_type . (tail(
(assert-typeof( 'get-strict-function::ctx ctx Context ))
(assert-typeof( 'get-strict-function::v v Atom ))
(match (context::lookup( ctx v arg_type )) (
()
( (Fragment( body )) (
(Fragment body)
))
( (GlobalFunction( body )) (
(GlobalFunction body)
))
( (GlobalVariable( body )) (
(GlobalVariable body)
))
( (Label lid) (
(Label lid)
))
( (LocalVariable sv-offset) (
(LocalVariable sv-offset)
))
( () (fail( UndefinedSymbol v arg_type )))
( u (fail( UnknownStrictFunction v arg_type u )))
))
));
strict-cstring-cache := ();
strict-declare-cstring := λ value . (tail(
(local uid)
(local cache)
(set cache strict-cstring-cache)
(while cache (tail(
(if (eq( (head(tail( cache ))) value )) (tail(
(set uid (tail(tail( cache ))))
(set cache ())
)) (
(set cache (head cache))
))
)))
(if uid () (tail(
(set uid (uuid()))
(set assemble-data-section (assemble-data-section (
uid ': \n
'.ascii \s '" (escape-literal value) '" \n
'.zero \s '1 \n
)))
(set strict-cstring-cache (strict-cstring-cache (value uid)))
)))
uid
));
strict-codegen-type-case := λ ctx base-type type-body case-number . (tail(
(assert-typeof( 'strict-codegen-type-case::ctx ctx Context ))
(if (typecheck-is-fragment base-type) () (match type-body (
()
( (App( (Literal enum-case) args )) (tail(
(local args-type)
(set args-type (typecheck-infer-type-compound args))
(set args-type (Cons( args-type U64 )))
(local taggeds-size)
(set taggeds-size (typecheck-sizeof base-type))
(local case-size)
(set case-size (typecheck-sizeof args-type))
(local case-padding)
(set case-padding (i2s(add( (s2i taggeds-size) (inv(s2i( case-size ))) ))))
#define 'push initializer
(local body)
(set body (Fragment (Lambda(
(App( (App( (Literal ':) (Variable 'src) )) (Literal Constant) ))
(App( (Variable '.program) (
(if (eq( case-padding 0 )) () (
\t 'sub \s '$ case-padding , \s '%rsp \n
))
(App( (Variable '.program) (Variable 'src) ))
DontChain
\t 'pushq \s '$ case-number \n
)))
))))
(typecheck-ascript( body ('->(
(And( enum-case base-type ))
Nil
))))
(set ctx (context::bind( ctx 'push body )))
#define 'mov local initializer
(local body)
(set body (Fragment (Lambda(
(App(
(App( (App( (Literal ':) (Variable 'src) )) (Literal Constant) ))
(App( (App( (Literal ':) (Variable 'dst) )) (Literal LocalVariable) ))
))
(App( (Variable '.program) (
DontChain
(if (eq( case-padding 0 )) () (
\t 'sub \s '$ case-padding , \s '%r15 \n
))
(App( (Variable '.program) (Variable 'src) ))
\t 'mov \s '%rbp , \s '%r15 \n
\t 'add \s '$ (Variable 'dst) , \s '%r15 \n
\t 'mov \s '$ case-size , \s '%r14 \n
('label 'while-push-start) ': \n
\t 'cmp \s '$0 , \s '%r14 \n
\t 'je \s ('label 'while-push-end) \n
\t 'pop \s 0 \[ '%r15 \] \n
\t 'sub \s '$8 , \s '%r14 \n
\t 'add \s '$8 , \s '%r15 \n
\t 'jmp \s ('label 'while-push-start) \n
('label 'while-push-end) ': \n
)))
))))
(typecheck-ascript( body ('->(
(Cons( (And( enum-case base-type )) LocalVariable ))
Nil
))))
(set ctx (context::bind( ctx 'mov body )))
#define 'mov global initializer
(local body)
(set body (Fragment (Lambda(
(App(
(App( (App( (Literal ':) (Variable 'src) )) (Literal Constant) ))
(App( (App( (Literal ':) (Variable 'dst) )) (Literal GlobalVariable) ))
))
(App( (Variable '.program) (
DontChain
(if (eq( case-padding 0 )) () (
\t 'sub \s '$ case-padding , \s '%rsp \n
))
(App( (Variable '.program) (Variable 'src) ))
\t 'mov \s '$ (Variable 'dst) , \s '%r15 \n
\t 'mov \s '$ case-size , \s '%r14 \n
('label 'while-push-start) ': \n
\t 'cmp \s '$0 , \s '%r14 \n
\t 'je \s ('label 'while-push-end) \n
\t 'pop \s 0 \[ '%r15 \] \n
\t 'sub \s '$8 , \s '%r14 \n
\t 'add \s '$8 , \s '%r15 \n
\t 'jmp \s ('label 'while-push-start) \n
('label 'while-push-end) ': \n
)))
))))
(typecheck-ascript( body ('->(
(Cons( (And( enum-case base-type )) GlobalVariable ))
Nil
))))
(set ctx (context::bind( ctx 'mov body )))
#define field accessors
(local field-offset)
(set field-offset 0)
(local field-number)
(set ctx (strict-bind-accessors( ctx base-type U64 0 () )))
(while args-type (match args-type (
()
( (Cons( lt rt )) (tail(
(set ctx (strict-bind-accessors( ctx enum-case rt field-offset field-number )))
(set field-offset (i2s(add(
(s2i field-offset)
(s2i(max( 8 (typecheck-sizeof rt) )))
))))
(set field-number (inc field-number))
(set args-type lt)
)))
( tt (tail(
(set ctx (strict-bind-accessors( ctx enum-case tt field-offset field-number )))
(set args-type ())
)))
)))
)))
( (Literal enum-case) (tail(
(local taggeds-size)
(set taggeds-size (typecheck-sizeof base-type))
(local case-size)
(set case-size 8)
(local case-padding)
(set case-padding (i2s(add( (s2i taggeds-size) (inv(s2i( case-size ))) ))))
#define 'push initializer
(local body)
(set body (Fragment (Lambda(
(App( (App( (Literal ':) (Variable 'src) )) (Literal Constant) ))
(App( (Variable '.program) (
(if (eq( case-padding 0 )) () (
\t 'sub \s '$ case-padding , \s '%rsp \n
))
DontChain
\t 'pushq \s '$ case-number \n
)))
))))
(typecheck-ascript( body ('->(
(And( enum-case base-type ))
StackVariable
))))
(set ctx (context::bind( ctx 'push body )))
#define 'mov local initializer
(local body)
(set body (Fragment (Lambda(
(App(
(App( (App( (Literal ':) (Variable 'src) )) (Literal Constant) ))
(App( (App( (Literal ':) (Variable 'dst) )) (Literal LocalVariable) ))
))
(App( (Variable '.program) (
DontChain
\t 'mov \s '%rbp , \s '%r15 \n
\t 'add \s '$ (Variable 'dst) , \s '%r15 \n
\t 'movq \s '$ case-number , \s 0 \[ '%r15 \] \n
)))
))))
(typecheck-ascript( body ('->(
(Cons( (And( enum-case base-type )) LocalVariable ))
Nil
))))
(set ctx (context::bind( ctx 'mov body )))
#define 'mov global initializer
(local body)
(set body (Fragment (Lambda(
(App(
(App( (App( (Literal ':) (Variable 'src) )) (Literal Constant) ))
(App( (App( (Literal ':) (Variable 'dst) )) (Literal GlobalVariable) ))
))
(App( (Variable '.program) (
DontChain
\t 'mov \s '$ (Variable 'dst) , \s '%r15 \n
\t 'movq \s '$ case-number , \s 0 \[ '%r15 \] \n
(if (eq( case-padding 0 )) () (
\t 'sub \s '$ case-padding , \s '%r15 \n
))
)))
))))
(typecheck-ascript( body ('->(
(Cons( (And( enum-case base-type )) GlobalVariable ))
Nil
))))
(set ctx (context::bind( ctx 'mov body )))
#define '.0 accessor
(set body (Fragment (Lambda(
(App( (App( (Literal ':) (Variable 'src) )) (Literal LocalVariable) ))
(App(
(App( (Variable '.program) (
\t 'movq \s (App( (Variable '.expression) (Variable 'src) )) \s \[ '%rbp \] ,
\s '%r15 \n
)))
(App( (Variable '.expression) (
'r15
)))
))
))))
(typecheck-ascript( body ('->(
(And( base-type LocalVariable ))
Reg64
))))
(set ctx (context::bind( ctx '.0 body )))
)))
( () () )
( u (tail(
(fail ('strict-codegen-type-case u))
)))
)))
(assert-typeof( 'strict-codegen-type-case::ctx ctx Context ))
ctx
));
strict-codegen-type := λ ctx type-name type-body case-number . (match type-body (
()
( (App( (App( tds (Variable '|) )) body )) (tail(
(local base-type)
(set base-type (typecheck-infer-type-compound type-name))
(local next-case-number)
(set next-case-number (i2s(inc(s2i( case-number )))))
(set ctx (strict-codegen-type( ctx type-name tds next-case-number )))
(strict-codegen-type-case( ctx base-type body case-number ))
)))
( body (tail(
(local base-type)
(set base-type (typecheck-infer-type-compound type-name))
(strict-codegen-type-case( ctx base-type type-body case-number ))
)))
));
strict-bind-accessors := λ ctx base-type src-type field-offset field-number . (tail(
(local body)
(local register-name)
(local return-type)
(match (typecheck-sizeof src-type) (
()
(1 (tail(
(set register-name 'r15b)
(set return-type 'Reg8)
)))
(2 (tail(
(set register-name 'r15w)
(set return-type 'Reg16)
)))
(4 (tail(
(set register-name 'r15d)
(set return-type 'Reg32)
)))
(8 (tail(
(set register-name 'r15)
(set return-type 'Reg64)
)))
(_ (tail(
(set return-type ())
)))
))
(if return-type (tail(
(set body (Fragment (Lambda(
(App( (App( (Literal ':) (Variable 'src) )) (Literal LocalVariable) ))
(App(
(App( (Variable '.program) (
\t 'mov \s ('+( ('.expression 'src) field-offset )) \s \[ '%rbp \] ,
\s '% register-name \n
)))
(App( (Variable '.expression) (
register-name
)))
))
))))
(typecheck-ascript( body ('->(
(And( base-type LocalVariable ))
return-type
))))
(set ctx (context::bind( ctx (clone-rope( '. (i2s field-number) )) body )))
)) (tail(
(set body (Fragment (Lambda(
(App( (App( (Literal ':) (Variable 'src) )) (Literal LocalVariable) ))
(App( (Variable '.expression) (
('+( ('.expression 'src) field-offset ))
)))
))))
(typecheck-ascript( body ('->(
(And( base-type LocalVariable ))
LocalVariable
))))
(set ctx (context::bind( ctx (clone-rope( '. (i2s field-number) )) body )))
)))
ctx
));