stack-call := λ ctx function-name function-args offset . (tail(
(assert-typeof( 'stack-call::ctx ctx Context ))
(assert-typeof( 'stack-call::function-name function-name Atom ))
(assert-typeof( 'stack-call::offset offset Atom ))
(local e1)
(match (get-strict-function(ctx function-name (typecheck-lookup function-args))) (
()
( (GlobalFunction( body )) (tail(
(local e-args)
(set e-args (stack-call-destructure-args( ctx function-args offset 0 )))
(assert-typeof( 'stack-call::e-args e-args StrictExpr ))
(local e-call)
(set e-call (expr::new()))
(local copy-bytes)
(local src-offset)
(local copy-offset)
(set src-offset (s2i 8)) # stack pointer is 64 bits
(local copy-size)
(set copy-size (s2i (expr::get-expr e-args)))
(set copy-offset (inv( copy-size )))
(while copy-size (tail(
(set copy-bytes ( copy-bytes
\t 'mov \s (i2s( src-offset )) \[ '%rbp \] , \s '%rax \n
\t 'mov \s '%rax , \s (i2s( copy-offset )) \[ '%rbp \] \n
))
(set copy-offset (add( (s2i '8) copy-offset )))
(set src-offset (add( (s2i '8) src-offset )))
(set copy-size (add( (s2i '-8) copy-size )))
)))
(local args-size)
(set args-size (expr::get-expr e-args))
(if (eq( args-size 0 )) () (
(set args-size (max( '8 args-size )))
))
(set e-call (expr::set-prog( e-call (
\o \s 'call \s function-name \s ': \s (quote-s (typecheck-lookup function-args)) \n
(expr::get-frame e-args)
(expr::get-prog e-args)
(enter-function())
(if (eq( args-size 0 )) () (
( \t 'sub \s '$ args-size , \s '%rsp \n )
))
copy-bytes
(\t 'call \s (mangle-identifier( function-name (typecheck-lookup body) )) \n)
(if (eq( args-size 0 )) () (
( \t 'add \s '$ args-size , \s '%rsp \n )
))
(\t 'mov \s '%rbp, \s '%rsp \n
\t 'pop \s '%rbp \n)
(expr::get-unframe e-args)
))))
(set e-call (expr::set-expr( e-call (
(match (typecheck-sizeof (typecheck-rvalue (typecheck-lookup body))) (
()
( 1 'al )
( 2 'ax )
( 4 'eax )
( 8 'rax )
))
))))
(set e-call (expr::set-context( e-call ctx )))
(set e-call (expr::set-offset( e-call offset )))
e-call
)))
( (Fragment( body )) (tail(
(set e1 (expr::new()))
(set e1 (expr::set-offset( e1 offset )))
(set e1 (expr::set-context( e1 ctx )))
(local args)
(set args (stack-destructure-args( ctx function-args offset Fragment )))
(fragment-apply-direct(
(get-strict-function( ctx function-name (typecheck-lookup function-args) ))
args e1 ()
))
)))
( l (fail (UnknownFunctionCall function-name (typecheck-lookup function-args) l)) )
))
));
stack-call-destructure-args := λ ctx e-args offset args-size . (tail(
(assert-typeof( 'stack-call-destructure-args::offset offset Atom ))
(assert-typeof( 'stack-call-destructure-args::args-size args-size Atom ))
(match (typecheck-slot( (typecheck-lookup e-args) Cons )) (
()
( (Cons( lt rt )) (tail(
(local e1)
(local e2)
(match e-args (
()
( (App( inner outer )) (tail(
(set e1 (stack-call-push-arg( ctx outer offset args-size )))
(set e2 (stack-call-destructure-args( (expr::get-context e1) inner (expr::get-offset e1) (expr::get-expr e1) )))
(expr::chain( e1 e2 ))
)))
( u (fail (InvalidArgs e-args)))
))
)))
( tt (tail(
()
(stack-call-push-arg( ctx e-args offset args-size ))
)))
))
# Returns StrictExpr:
# frame (Add Size of Local Variable)
# program (evaluate args)
# unframe (Sub Size of Local Variable)
# expr (size of arguments)
));
stack-call-push-arg := λ ctx e-arg offset args-size . (tail(
(assert-typeof( 'stack-call-push-arg::offset offset Atom ))
(assert-typeof( 'stack-call-push-arg::args-size args-size Atom ))
(local e1)
(local e2)
(local et)
(set et (typecheck-lookup e-arg))
(local e-sz)
(set e-sz (typecheck-sizeof et))
(if (eq( e-sz '0 )) () (
(set e-sz (max( 8 e-sz )))
))
(set args-size (i2s(add( (s2i args-size) (s2i e-sz) ))) )
(local new-offset)
(set new-offset( (i2s(add( (s2i offset) (inv(s2i( e-sz ))) ))) ))
(local unframe)
(if (eq( e-sz '0 )) () (
(set unframe ( \t 'add \s '$ (max( '8 e-sz )) , \s '%rsp \n ))
))
(set e1 (compile-expr-strict( ctx e-arg new-offset Used )))
(set e1 (expr::set-type( e1 (typecheck-lookup e-arg))))
(if (typecheck-has-representation( typecheck-lookup e-arg )) (
(set e2 (fragment-apply(
ctx 'push (typecheck-lookup e-arg)
(() e1) e1
)))
) (
(set e2 e1)
))
(set e2 (expr::set-unframe( e2 ((expr::get-unframe e2) unframe) )))
(set e2 (expr::set-expr( e2 args-size )))
(set e2 (expr::set-offset( e2 new-offset )))
e2
));
stack-destructure-args := λ ctx function-args offset arg-mode . (tail(
(assert-typeof( 'stack-destructure-args::arg-mode arg-mode Atom ))
(match ( function-args (typecheck-slot( (typecheck-lookup function-args) Cons )) arg-mode ) (
()
( ( (App( fl fr )) (Cons( tl tr )) Fragment ) (tail(
(local inner-e)
(set inner-e (stack-destructure-args( ctx fl offset Fragment )))
(local outer-e)
(set outer-e (compile-expr-strict( ctx fr offset Used )))
(set outer-e (expr::set-type( outer-e (typecheck-lookup fr))))
(inner-e outer-e)
)))
( ( fa tt Fragment ) (tail(
(local outer-e)
(set outer-e (compile-expr-strict( ctx fa offset Used )))
(set outer-e (expr::set-type( outer-e (typecheck-lookup fa))))
(() outer-e)
)))
( u (fail ('stack-destructure-args u )))
))
));
stack-define := λ ctx fname lmb . (tail(
(assert-typeof( 'stack-define::ctx ctx Context ))
(match lmb (
()
( (Lambda( lhs rhs )) (tail(
(local e1)
(local e2)
(local text)
(set e1 (stack-define-destructure( ctx lhs () )))
(local stack_offset)
(set stack_offset (expr::get-offset e1))
(set stack_offset (i2s(add( (s2i(stack_offset)) (s2i '-8) ))) )
(set e2 (compile-expr-strict( (expr::get-context e1) rhs stack_offset Return)))
(set text ( text (mangle-identifier( fname (typecheck-lookup lmb) )) ': \n ))
(set text ( text (expr::get-frame e2) ))
(set text ( text (expr::get-prog e2) ))
(set text ( text (expr::get-unframe e2) ))
(set text ( text (\t 'ret \n) ))
(set text ( text (expr::get-text e2) ))
(local return)
(set return (expr::new()))
(set return (expr::set-text( return text )))
(set return (expr::set-data( return (expr::get-data e2) )))
return
)))
))
));
stack-define-destructure := λ ctx lhs offset . (match lhs (
()
( (App( (App( (Literal :) (Variable lname) )) ltype )) (tail(
(set ltype (typecheck-infer-type-compound ltype) )
(local size)
(set size (typecheck-sizeof ltype))
(set size (max( '8 size )))
(local new_offset)
(set new_offset (add( offset (inv(s2i size)) )) )
(local return)
(set ctx (context::bind( ctx lname
(typecheck-ascript( (LocalVariable (i2s new_offset)) ltype ))
)))
(set return (expr::new()))
(set return (expr::set-context( return ctx )))
(set return (expr::set-offset( return (i2s new_offset) )))
return
)))
( (App( more (App( (App( (Literal :) (Variable lname) )) ltype )) )) (tail(
(set ltype (typecheck-infer-type-compound ltype) )
(local size)
(set size (typecheck-sizeof ltype))
(set size (max( '8 size )))
(local new_offset)
(set new_offset (add( offset (inv(s2i size)) )) )
(local more-e)
(set more-e (stack-define-destructure( ctx more new_offset )))
(set ctx (context::bind( (expr::get-context more-e) lname
(typecheck-ascript( (LocalVariable (i2s new_offset)) ltype ))
)))
(local return)
(set return (expr::new()))
(set return (expr::set-context( return ctx )))
(set return (expr::set-offset( return (expr::get-offset more-e) )))
return
)))
( Nil (tail(
(local return)
(set return (expr::new()))
(set return (expr::set-context( return ctx )))
(set return (expr::set-offset( return offset )))
return
)))
( u (fail (UnknownStackArg lhs)))
));