- startTemplate =
- vcat
- [ text "extern void* realWorldZh_closure;"
- , ptext SLIT("STGFUN") <> parens (h_stub_nm)
- , lbrace
- , ptext SLIT("FUNBEGIN;")
- , text "RestoreAllStgRegs();"
- , stackCheck param_names
- , pushRetReg
- , pushCont
- , pushRealWorld
- , vcat (map pushArg (reverse param_names))
- , text "Node=" <> closure <> semi
- , text "ENT_VIA_NODE();" -- ticky count
- , text "InfoPtr=(D_)(INFO_PTR(Node));"
- , text "JMP_(ENTRY_CODE(InfoPtr));"
- , text "FUNEND;"
- , rbrace
- ]
-
- stopTemplate =
- vcat
- [ ptext SLIT("STGFUN") <> parens (text "stop" <> h_stub_nm <> text "DirectReturn")
- , lbrace
- , ptext SLIT("FUNBEGIN;")
- , assignResult
- , popRetReg
- , text "#if defined(__STG_GCC_REGS__)"
- , text "SaveAllStgRegs();"
- , text "#else"
- , text "SAVE_Hp = Hp;"
- , text "SAVE_HpLim = HpLim;"
- , text "#endif"
- , text "JMP_(miniInterpretEnd);"
- , text "FUNEND;"
- , rbrace
- ]
-
- vtblTemplate =
- vcat
- [ text "const W_ vtbl_" <> h_stub_nm <> text "[] = {"
- , vcat (punctuate comma (replicate 8 dir_ret))
- , text "};"
- ]
- where
- dir_ret = text "(W_)stop" <> h_stub_nm <> text "DirectReturn"
-
- assignResult =
- case res of
- Nothing -> empty
- Just _ -> res_name <> equals <> text "R3.i;" -- wrong
-
- pushRetReg =
- text "SpB -= BREL(1);" $$
- text "*SpB = (W_)RetReg;"
-
- popRetReg =
- text "RetReg=(StgRetAddr)*SpB;" $$
- text "SpB += BREL(1);"
-
- pushCont =
- text "RetReg=(StgRetAddr)UNVEC(stop" <> h_stub_nm <>
- text "DirectReturn,vtbl_" <> h_stub_nm <> text ");"
-
- pushRealWorld =
- text "SpB -= BREL(1);" $$
- text "*SpB = (W_)realWorldZh_closure;"
-
-
- pushArg nm =
- text "SpB -= BREL(1);" $$
- text "*SpB = (W_)" <> nm <> semi
-
- stackCheck args =
- text "STK_CHK(LivenessReg,0," <> sz <> text ",0,0,0,0);"
- where
- sz = parens $
- hsep $ punctuate (text " + ") (text "1":(map sizer args))
-
- sizer x = text "BYTES_TO_STGWORDS" <> parens (text "sizeof" <> parens x)
-
-foreign_export_prefix :: String
-foreign_export_prefix = "__fexp_"
-
-mkCStub :: FAST_STRING -> SDoc -> [Type] -> Maybe Type -> CallConv -> (SDoc, SDoc)
-mkCStub c_nm h_stub_nm args res cc =
- ( hsep [ ptext SLIT("extern")
- , cResType
- , pprCconv
- , ptext c_nm
- , parens (hsep (punctuate comma (zipWith (<+>) stubParamTypes stubArgs)))
- , semi
- ]
- , vcat
- [ externDecls
- , cResType
- , pprCconv
- , ptext c_nm <> parens (hsep (punctuate comma stubArgs))
- , vcat (zipWith declVar stubParamTypes stubArgs)
- , lbrace
- , vcat (zipWith assignArgs param_names c_args)
- , text "miniInterpret" <> parens (parens (text "StgFunPtr") <> h_stub_nm) <> semi
- , returnResult
- , rbrace
- ]
- )
- where
- -- tedious hack to let us deal with caller-cleans-up-stack
- -- discipline that the C calling convention uses.
- stubParamTypes
- | cc == cCallConv = ptext SLIT("void*") : cParamTypes
- | otherwise = cParamTypes
- stubArgs
- | cc == cCallConv = ptext SLIT("_a0") : c_args
- | otherwise = c_args
-
- param_names = zipWith (\ i _ -> h_stub_nm <> text ('_':show i)) [1..] args
- cParamTypes = map (text.showPrimRepToUser.typePrimRep) args
- (cResType, cResDecl) =
- case res of
- Nothing -> (text "void", empty)
- Just t -> (text (showPrimRepToUser (typePrimRep t)),
- text "extern" <+> cResType <+> res_name <> semi)
-
- pprCconv
- | cc == cCallConv = empty
- | otherwise = pprCallConv cc
-
- externDecls =
- vcat (zipWith mkExtern cParamTypes param_names) $$
- cResDecl $$
- text "extern void" <+> h_stub_nm <> text "();"
-
- mkExtern ty nm = text "extern" <+> ty <+> nm <> semi
-
- c_args = zipWith (\ _ n -> text ('a':show n)) args [0..]
-
- assignArgs p_nm c_arg = p_nm <+> equals <+> c_arg <> semi
-
- returnResult =
- case res of
- Nothing -> empty
- Just _ -> text "return" <+> res_name <> semi
-
- (res_name, res_ty) =
- case res of
- Nothing -> (empty, empty)
- Just t -> (h_stub_nm <> text "_res", ppr (typePrimRep t))
-
-declVar :: SDoc -> SDoc -> SDoc
-declVar ty var = ty <+> var <> semi