From 5449b6f2aba319ff262a685f96b618eb8aad6e5e Mon Sep 17 00:00:00 2001 From: Tim Whiting Date: Sat, 17 May 2025 16:30:23 -0600 Subject: [PATCH] macros for functions --- kklib/include/kklib.h | 94 ++++++++++++++++++++++++++++++++++++--- src/Backend/C/FromCore.hs | 54 +++++++++++++--------- 2 files changed, 121 insertions(+), 27 deletions(-) diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index c63396152..4eb3ebcdb 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -1178,15 +1178,99 @@ static inline void kk_datatype_ptr_decref(kk_datatype_t d, kk_context_t* ctx) { #define kk_datatype_as(tp,v,ctx) (kk_block_as(tp,kk_datatype_as_ptr(v,ctx))) #define kk_datatype_as_assert(tp,v,tag,ctx) (kk_block_assert(tp,kk_datatype_as_ptr(v,ctx),tag)) +#define kk_define_closure0(fname, tname, new_name, storage_new, unused_fsize) \ + struct tname { \ + struct kk_function_s _base; \ + }; \ + storage_new kk_function_t new_name(kk_context_t* _ctx) { \ + kk_define_static_function(_fself, fname, _ctx) \ + return kk_function_static_dup(_fself, _ctx); \ + } +#define kk_define_closure1(fname, tname, new_name, storage_new, fsize, arg1tp, arg1nm) \ + struct tname { \ + struct kk_function_s _base; \ + arg1tp arg1nm; \ + }; \ + storage_new kk_function_t new_name(arg1tp arg1nm, kk_context_t* _ctx) { \ + struct tname* _self = kk_function_alloc_as(struct tname, fsize, _ctx); \ + _self->_base.fun = kk_kkfun_ptr_box(&fname, _ctx); \ + _self->arg1nm = arg1nm; \ + return kk_datatype_from_base(&_self->_base, _ctx); \ + } -static inline kk_datatype_t kk_datatype_null(void) { - kk_datatype_t d = { kk_datatype_null_init }; - return d; -} +#define kk_define_closure2(fname, tname, new_name, storage_new, fsize, arg1tp, arg1nm, arg2tp, arg2nm) \ + struct tname { \ + struct kk_function_s _base; \ + arg1tp arg1nm; \ + arg2tp arg2nm; \ + }; \ + storage_new kk_function_t new_name(arg1tp arg1nm, arg2tp arg2nm, kk_context_t* _ctx) { \ + struct tname* _self = kk_function_alloc_as(struct tname, fsize, _ctx); \ + _self->_base.fun = kk_kkfun_ptr_box(&fname, _ctx); \ + _self->arg1nm = arg1nm; \ + _self->arg2nm = arg2nm; \ + return kk_datatype_from_base(&_self->_base, _ctx); \ + } + +#define kk_define_closure3(fname, tname, new_name, storage_new, fsize, arg1tp, arg1nm, arg2tp, arg2nm, arg3tp, arg3nm) \ + struct tname { \ + struct kk_function_s _base; \ + arg1tp arg1nm; \ + arg2tp arg2nm; \ + arg3tp arg3nm; \ + }; \ + storage_new kk_function_t new_name(arg1tp arg1nm, arg2tp arg2nm, arg3tp arg3nm, kk_context_t* _ctx) { \ + struct tname* _self = kk_function_alloc_as(struct tname, fsize, _ctx); \ + _self->_base.fun = kk_kkfun_ptr_box(&fname, _ctx); \ + _self->arg1nm = arg1nm; \ + _self->arg2nm = arg2nm; \ + _self->arg3nm = arg3nm; \ + return kk_datatype_from_base(&_self->_base, _ctx); \ + } + +#define kk_define_closure4(fname, tname, new_name, storage_new, fsize, arg1tp, arg1nm, arg2tp, arg2nm, arg3tp, arg3nm, arg4tp, arg4nm) \ + struct tname { \ + struct kk_function_s _base; \ + arg1tp arg1nm; \ + arg2tp arg2nm; \ + arg3tp arg3nm; \ + arg4tp arg4nm; \ + }; \ + storage_new kk_function_t new_name(arg1tp arg1nm, arg2tp arg2nm, arg3tp arg3nm, arg4tp arg4nm, kk_context_t* _ctx) { \ + struct tname* _self = kk_function_alloc_as(struct tname, fsize, _ctx); \ + _self->_base.fun = kk_kkfun_ptr_box(&fname, _ctx); \ + _self->arg1nm = arg1nm; \ + _self->arg2nm = arg2nm; \ + _self->arg3nm = arg3nm; \ + _self->arg4nm = arg4nm; \ + return kk_datatype_from_base(&_self->_base, _ctx); \ + } + +#define kk_define_closure5(fname, tname, new_name, storage_new, fsize, arg1tp, arg1nm, arg2tp, arg2nm, arg3tp, arg3nm, arg4tp, arg4nm, arg5tp, arg5nm) \ + struct tname { \ + struct kk_function_s _base; \ + arg1tp arg1nm; \ + arg2tp arg2nm; \ + arg3tp arg3nm; \ + arg4tp arg4nm; \ + arg5tp arg5nm; \ + }; \ + storage_new kk_function_t new_name(arg1tp arg1nm, arg2tp arg2nm, arg3tp arg3nm, arg4tp arg4nm, arg5tp arg5nm, kk_context_t* _ctx) { \ + struct tname* _self = kk_function_alloc_as(struct tname, fsize, _ctx); \ + _self->_base.fun = kk_kkfun_ptr_box(&fname, _ctx); \ + _self->arg1nm = arg1nm; \ + _self->arg2nm = arg2nm; \ + _self->arg3nm = arg3nm; \ + _self->arg4nm = arg4nm; \ + _self->arg5nm = arg5nm; \ + return kk_datatype_from_base(&_self->_base, _ctx); \ + } + +static const kk_datatype_t kk_datatype_null = { kk_datatype_null_init }; static inline bool kk_datatype_is_null(kk_datatype_t d) { - return kk_datatype_eq(d, kk_datatype_null()); + return kk_datatype_eq(d, kk_datatype_null); } static inline kk_datatype_t kk_datatype_unbox(kk_box_t b) { diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index a10545fee..5b5b46bd9 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -1140,7 +1140,7 @@ genHoleCall tp = -- ppType tp <.> text "_hole()") CPrim "kk_integer_t" -> text "kk_integer_zero" CPrim "kk_string_t" -> text "kk_string_empty()" CPrim "kk_vector_t" -> text "kk_vector_empty()" - _ -> text "kk_datatype_null()" + _ -> text "kk_datatype_null" conBaseCastNameInfo :: ConInfo -> Doc @@ -1235,34 +1235,44 @@ genLambda params eff body getDataInfo name = do newtypes <- getNewtypes return (newtypesLookupAny name newtypes) (allFields,vrepr) <- orderConFields emitError nameDoc getDataInfo platform 1 {- base.fun -} freeVars - + let (paddingFields,fields) = partition (isPaddingName . fst) allFields + canUseMacro = length allFields <= 5 && null paddingFields -- only one function in the standard library is greater than 5, none have padding fields. scanCount = valueReprScanCount vrepr -- fieldDocs = [ppType tp <+> ppName name | (name,tp) <- allFields] - tpDecl = text "struct" <+> ppName funTpName <+> block ( - vcat ([text "struct kk_function_s _base;"] ++ - [ppType tp <+> ppName name <.> semi | (name,tp) <- allFields]) - ) <.> semi -- <-> text "kk_struct_packed_end" + tpDecl = if canUseMacro then empty else + text "struct" <+> ppName funTpName <+> block ( + vcat ([text "struct kk_function_s _base;"] ++ + [ppType tp <+> ppName name <.> semi | (name,tp) <- allFields]) + ) <.> semi -- <-> text "kk_struct_packed_end" funSig = text (if toH then "extern" else "static") <+> ppType (typeOf body) - <+> ppName funName <.> parameters ([text "kk_function_t _fself"] ++ + <+> ppName funName <.> parameters ([text "kk_function_t _fself"] ++ [ppType tp <+> ppName name | (TName name tp) <- params]) - newDef = funSig <.> semi - <-> text (if toH then "static inline" else "static") - <+> text "kk_function_t" <+> ppName newName <.> ntparameters fields <+> block ( vcat ( - if (null fields) - then [text "kk_define_static_function" <.> arguments [text "_fself", ppName funName] -- <.> semi - --text "static" <+> structDoc <+> text "_self =" - -- <+> braces (braces (text "static_header(1, TAG_FUNCTION), box_cptr(&" <.> ppName funName <.> text ")")) <.> semi - , text "return kk_function_static_dup(_fself,kk_context());"] - else [structDoc <.> text "* _self = kk_function_alloc_as" <.> arguments [structDoc, pretty scanCount - ] <.> semi - ,text "_self->_base.fun = kk_kkfun_ptr_box(&" <.> ppName funName <.> text ", kk_context());"] - ++ [text "_self->" <.> ppName name <+> text "=" <+> ppName name <.> semi | (name,_) <- fields] - ++ [text "_self->" <.> ppName paddingName <+> text "= kk_box_null();" | (paddingName,_) <- paddingFields] - ++ [text "return kk_datatype_from_base(&_self->_base, kk_context());"]) - ) + newDef = if canUseMacro then + funSig <.> semi <-> + text "kk_define_closure" <.> pretty (length allFields) <.> + tupled ([ppName funName, ppName funTpName, ppName newName, + text (if toH then "static inline" else "static"), -- New Closure + pretty scanCount] ++ + [ppType tp <.> comma <+> ppName name | (name,tp) <- allFields]) <.> semi + else + funSig <.> semi + <-> text (if toH then "static inline" else "static") + <+> text "kk_function_t" <+> ppName newName <.> ntparameters fields <+> block ( vcat ( + if (null fields) + then [text "kk_define_static_function" <.> arguments [text "_fself", ppName funName] -- <.> semi + --text "static" <+> structDoc <+> text "_self =" + -- <+> braces (braces (text "static_header(1, TAG_FUNCTION), box_cptr(&" <.> ppName funName <.> text ")")) <.> semi + , text "return kk_function_static_dup(_fself,kk_context());"] + else [structDoc <.> text "* _self = kk_function_alloc_as" <.> arguments [structDoc, pretty scanCount + ] <.> semi + ,text "_self->_base.fun = kk_kkfun_ptr_box(&" <.> ppName funName <.> text ", kk_context());"] + ++ [text "_self->" <.> ppName name <+> text "=" <+> ppName name <.> semi | (name,_) <- fields] + ++ [text "_self->" <.> ppName paddingName <+> text "= kk_box_null();" | (paddingName,_) <- paddingFields] + ++ [text "return kk_datatype_from_base(&_self->_base, kk_context());"]) + ) emitToCurrentDef (vcat [linebreak,text "// lift anonymous function", tpDecl, newDef] <.> linebreak)