assemble-text-section := ();
assemble-data-section := ();
assemble-argv-referenced := ();
assemble := λprogram . (
(local target)
(set target 'tmp.s)
(while cli-config (tail(
(match (tail cli-config) (
()
((Target t) (set target t))
))
(set cli-config (head cli-config))
)))
(local main_e)
(local main_pd)
(local e1)
(local e2)
(local output_pd)
(set output_pd ( () () ))
(local global_ctx)
(set global_ctx (context::new()))
(local preview_program)
(set preview_program program)
(while preview_program (match preview_program (
()
( (pc (Global ('main (
(Lambda( lhs rhs ))
)))) (
(set global_ctx (context::bind( global_ctx 'argc
(typecheck-ascript( (GlobalVariable 'argc) (parse-type 'U64+GlobalVariable) ))
)))
(set global_ctx (context::bind( global_ctx 'argv
(typecheck-ascript( (GlobalVariable 'argv) (parse-type 'String[?]+GlobalVariable) ))
)))
(set assemble-argv-referenced True)
(set preview_program pc)
))
( (pc1 (Global ('main body))) (
(set preview_program pc1)
))
( (pc2 (GExpr e)) (
(set preview_program pc2)
))
( (pc3 (Global (fname body))) (
(match body (
()
( Nil (tail(
(set output_pd (
(head output_pd)
(
(tail output_pd)
(label-case fname)
': \n \t '.zero \s '16 \n
)
))
(set global_ctx (context::bind( global_ctx fname
(typecheck-ascript( (GlobalVariable body) (typecheck-lookup body) ))
)))
)))
( (Lambda(lhs rhs)) (tail(
(set global_ctx (context::bind( global_ctx fname
(typecheck-ascript( (GlobalFunction body) (typecheck-lookup body) ))
)))
)))
( (App( (App( (Literal ':) body-initial )) body-type )) (tail(
(local mtype)
(set mtype (typecheck-lookup body))
(local mname)
(set mname (mangle-identifier( fname mtype )))
(set output_pd (
(head output_pd)
(
(tail output_pd)
mname ': \n
(assemble-initialize-data( body-initial mtype ))
)
))
(set global_ctx (context::bind( global_ctx fname
(typecheck-ascript( (GlobalVariable mname) mtype ))
)))
)))
( other (tail(
(fail (GlobalsMustBeAscripted other))
)))
))
(set preview_program pc3)
))
( (prog (Fragment( (Variable fname) fbody ))) (
(set global_ctx (context::bind( global_ctx fname
(typecheck-ascript( (Fragment fbody) (typecheck-lookup fbody) ))
)))
(set preview_program prog)
))
( (prog (Type( tn tb ))) (
(set global_ctx (strict-codegen-type( global_ctx tn tb 0 )) )
(set preview_program prog)
))
( (prog (Size( _ _ ))) (
(set preview_program prog)
))
( u (
(fail (UnexpectedProgram (tail u)))
))
)))
(while program (match program (
()
( (pc (Global ('main (
(Lambda( lhs rhs ))
)))) (
(set main_e rhs)
(set program pc)
))
( (pc (Global ('main body))) (
(set main_e body)
(set program pc)
))
( (pc (GExpr e)) (
(set main_pd (compile-append( main_pd global_ctx e )))
(set program pc)
))
( (pc (Global (fname body))) (
(match body (
()
( Nil (
))
( (Lambda(lhs rhs)) (
(if config-strict (
(set e1 (stack-define( global_ctx fname body )))
) (
(set e1 (define-calling-convention-s( global_ctx fname body )))
))
(set output_pd (
( (head output_pd) (expr::get-text e1) )
( (tail output_pd) (expr::get-data e1) )
))
))
( (App( (App( (Literal ':) body-initial )) body-type )) (tail(
(local mtype)
(set mtype (typecheck-lookup body-initial))
(local lhs)
(set lhs (Variable fname))
(typecheck-ascript( lhs mtype ))
(set main_pd (compile-append(
main_pd global_ctx
(App( (App( (Variable 'set) lhs )) body-initial ))
)))
)))
))
(set program pc)
))
( (pc (Fragment( _ _ ))) (
(set program pc)
))
( (pc (Type( _ _ ))) (
(set program pc)
))
( (pc (Size( _ _ ))) (
(set program pc)
))
( u (
(fail (UnexpectedProgram (tail u)))
))
)))
(if main_e (
(set main_pd (compile-append( main_pd global_ctx main_e )))
) ())
(set output_pd (
(
(assemble-program-header())
(before-main())
(if assemble-argv-referenced (assemble-argv-prog-header()) ())
(enter-function())
(expr::get-frame main_pd)
(expr::get-prog main_pd)
(expr::get-unframe main_pd)
(exit-cleanup())
(head output_pd)
(expr::get-text main_pd)
(if config-nostd () (stdlib-functions()))
)
( (if config-nostd () (stdlib-data()))
(tail output_pd) (expr::get-data main_pd)
(if assemble-argv-referenced (assemble-argv-data-header()) ())
)
))
(set output_pd (
((head output_pd) assemble-text-section)
((assemble-data-header()) (tail output_pd) assemble-data-section)
))
(write-file (target (clone-rope output_pd)))
(debug-memory-usage 'assemble)
);
assemble-initialize-data := λ e tt . (
(match e (
()
( (Literal v) (match (typecheck-datatype tt) (
()
(I8 ( \t '.byte \s v \n ))
(U8 (tail(
(if (eq( v True )) (set v '1) ())
(if (eq( v False )) (set v '0) ())
(\t '.byte \s v \n)
)))
(I16 ( \t '.2byte \s v \n ))
(U16 ( \t '.2byte \s v \n ))
(I32 ( \t '.4byte \s v \n ))
(U32 ( \t '.4byte \s v \n ))
(I64 ( \t '.8byte \s v \n ))
(U64 ( \t '.8byte \s v \n ))
(_ ( \t '.zero \s (typecheck-sizeof tt) \n ))
)))
( _ (
\t '.zero \s (typecheck-sizeof tt) \n
))
))
);
assemble-data-header := λ .(
'.data \n
);
assemble-argv-data-header := λ .(
'argc: \n
\t '.zero \s 8 \n
'argv: \n
\t '.zero \s 8192 \n
);
assemble-argv-prog-header := λ .(
\t 'pop \s '%r15 \n
\t 'mov \s '$argc , \s '%r14 \n
\t 'mov \s '%r15 , \s '0 \[ '%r14 \] \n
\t 'mov \s '$argv , \s '%r14 \n
'argv_populate_loop_begin: \n
\t 'cmp \s '$0 , \s '%r15 \n
\t 'je \s 'argv_populate_loop_end \n
\t 'pop \s '%r13 \n
\t 'mov \s '%r13 , \s '0 \[ '%r14 \] \n
\t 'add \s '$8 , \s '%r14 \n
\t 'dec \s '%r15 \n
\t 'jmp \s 'argv_populate_loop_begin \n
'argv_populate_loop_end: \n
);
assemble-program-header := λ .(
'.global \s '_start \n
'.text \n
'_start: \n
\t 'jmp \s 'main \n
);