diff -u ghc-6.4/ghc/compiler/deSugar/DsForeign.lhs ghc-6.5/ghc/compiler/deSugar/DsForeign.lhs --- ghc-6.4/ghc/compiler/deSugar/DsForeign.lhs 2005-05-07 11:51:04.000000000 +0900 +++ ghc-6.5/ghc/compiler/deSugar/DsForeign.lhs 2005-05-07 11:51:04.000000000 +0900 @@ -24,14 +24,14 @@ import Type ( isUnLiftedType ) #endif import MachOp ( machRepByteWidth, MachRep(..) ) -import SMRep ( argMachRep, primRepToCgRep ) +import SMRep ( argMachRep, typeCgRep ) import CoreUtils ( exprType, mkInlineMe ) import Id ( Id, idType, idName, mkSysLocal, setInlinePragma ) import Literal ( Literal(..), mkStringLit ) import Module ( moduleString ) import Name ( getOccString, NamedThing(..) ) import OccName ( encodeFS ) -import Type ( repType, coreEqType, typePrimRep ) +import Type ( repType, coreEqType ) import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp, mkFunTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs, @@ -52,7 +52,7 @@ import BasicTypes ( Activation( NeverActive ) ) import SrcLoc ( Located(..), unLoc ) import Outputable -import Maybe ( fromJust ) +import Maybe ( fromJust, isNothing ) import FastString \end{code} @@ -95,7 +95,7 @@ combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) (L loc (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr)) = dsFExport id (idType id) - ext_nm cconv False `thenDs` \(h, c, _) -> + ext_nm cconv False `thenDs` \(h, c, _, _) -> warnDepr depr loc `thenDs` \_ -> returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb), acc_f) @@ -292,7 +292,8 @@ -- the first argument's stable pointer -> DsM ( SDoc -- contents of Module_stub.h , SDoc -- contents of Module_stub.c - , [Type] -- primitive arguments expected by stub function. + , [MachRep] -- primitive arguments expected by stub function + , Int -- size of args to stub function ) dsFExport fn_id ty ext_name cconv isDyn @@ -371,7 +372,8 @@ in dsLookupGlobalId bindIOName `thenDs` \ bindIOId -> newSysLocalDs stable_ptr_ty `thenDs` \ stbl_value -> - dsFExport id export_ty fe_nm cconv True `thenDs` \ (h_code, c_code, stub_args) -> + dsFExport id export_ty fe_nm cconv True + `thenDs` \ (h_code, c_code, arg_reps, args_size) -> let stbl_app cont ret_ty = mkApps (Var bindIOId) [ Type stable_ptr_ty @@ -395,9 +397,7 @@ -- (probably in the RTS.) adjustor = FSLIT("createAdjustor") - arg_type_info = drop 2 $ map (repCharCode.argMachRep - .primRepToCgRep.typePrimRep) - stub_args + arg_type_info = map repCharCode arg_reps repCharCode F32 = 'f' repCharCode F64 = 'd' repCharCode I64 = 'l' @@ -407,17 +407,9 @@ -- so that we can attach the '@N' suffix to its label if it is a -- stdcall on Windows. mb_sz_args = case cconv of - StdCallConv -> Just (sum (map ty_size stub_args)) + StdCallConv -> Just args_size _ -> Nothing - -- NB. the calculation here isn't strictly speaking correct. - -- We have a primitive Haskell type (eg. Int#, Double#), and - -- we want to know the size, when passed on the C stack, of - -- the associated C type (eg. HsInt, HsDouble). We don't have - -- this information to hand, but we know what GHC's conventions - -- are for passing around the primitive Haskell types, so we - -- use that instead. I hope the two coincide --SDM - ty_size = machRepByteWidth.argMachRep.primRepToCgRep.typePrimRep in dsCCall adjustor adj_args PlayRisky io_res_ty `thenDs` \ ccall_adj -> -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback @@ -464,33 +456,33 @@ -> CCallConv -> (SDoc, SDoc, - [Type] -- the *primitive* argument types + [MachRep], -- the argument reps + Int -- total size of arguments ) mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc - = (header_bits, c_bits, all_prim_arg_tys) + = (header_bits, c_bits, + [rep | (_,_,_,rep) <- arg_info], -- just the real args + sum [ machRepByteWidth rep | (_,_,_,rep) <- aug_arg_info] -- all the args + ) where - -- Create up types and names for the real args - arg_cnames, arg_ctys :: [SDoc] - arg_cnames = mkCArgNames 1 arg_htys - arg_ctys = map showStgType arg_htys - - -- and also for auxiliary ones; the stable ptr in the dynamic case, and - -- a slot for the dummy return address in the dynamic + ccall case - extra_cnames_and_tys - = case maybe_target of - Nothing -> [((text "the_stableptr", text "StgStablePtr"), mkStablePtrPrimTy alphaTy)] - other -> [] - ++ - case (maybe_target, cc) of - (Nothing, CCallConv) -> [((text "original_return_addr", text "void*"), addrPrimTy)] - other -> [] - - all_cnames_and_ctys :: [(SDoc, SDoc)] - all_cnames_and_ctys - = map fst extra_cnames_and_tys ++ zip arg_cnames arg_ctys - - all_prim_arg_tys - = map snd extra_cnames_and_tys ++ map getPrimTyOf arg_htys + -- list the arguments to the C function + arg_info :: [(SDoc, -- arg name + SDoc, -- C type + Type, -- Haskell type + MachRep)] -- the MachRep + arg_info = [ (text ('a':show n), showStgType ty, ty, + typeMachRep (getPrimTyOf ty)) + | (ty,n) <- zip arg_htys [1..] ] + + -- add some auxiliary args; the stable ptr in the wrapper case, and + -- a slot for the dummy return address in the wrapper + ccall case + aug_arg_info + | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info + | otherwise = arg_info + + stable_ptr_arg = + (text "the_stableptr", text "StgStablePtr", undefined, + typeMachRep (mkStablePtrPrimTy alphaTy)) -- stuff to do with the return type of the C function res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes @@ -506,8 +498,8 @@ header_bits = ptext SLIT("extern") <+> fun_proto <> semi fun_proto = cResType <+> pprCconv <+> ftext c_nm <> - parens (hsep (punctuate comma (map (\(nm,ty) -> ty <+> nm) - all_cnames_and_ctys))) + parens (hsep (punctuate comma (map (\(nm,ty,_,_) -> ty <+> nm) + aug_arg_info))) -- the target which will form the root of what we ask rts_evalIO to run the_cfun @@ -517,9 +509,9 @@ -- the expression we give to rts_evalIO expr_to_run - = foldl appArg the_cfun (zip arg_cnames arg_htys) + = foldl appArg the_cfun arg_info -- NOT aug_arg_info where - appArg acc (arg_cname, arg_hty) + appArg acc (arg_cname, _, arg_hty, _) = text "rts_apply" <> parens (acc <> comma <> mkHObj arg_hty <> parens arg_cname) @@ -538,6 +530,30 @@ Nothing -> empty Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi + -- the only reason for making the mingw32 (anything targetting PE, really) stick + -- out here is that the GHCi linker isn't capable of handling .ctors sections + useStaticConstructors +#if defined(mingw32_HOST_OS) + = False +#else + = True +#endif + + initialiser + = case maybe_target of + Nothing -> empty + Just hs_fn + | not useStaticConstructors -> empty + | otherwise -> + vcat + [ text "static void stginit_export_" <> ppr hs_fn + <> text "() __attribute__((constructor));" + , text "static void stginit_export_" <> ppr hs_fn <> text "()" + , braces (text "getStablePtr" + <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure") + <> semi) + ] + -- finally, the whole darn thing c_bits = space $$ @@ -568,11 +584,17 @@ , if res_hty_is_unit then empty else text "return cret;" , rbrace - ] - + ] $$ + initialiser -mkCArgNames :: Int -> [a] -> [SDoc] -mkCArgNames n as = zipWith (\ _ n -> text ('a':show n)) as [n..] +-- NB. the calculation here isn't strictly speaking correct. +-- We have a primitive Haskell type (eg. Int#, Double#), and +-- we want to know the size, when passed on the C stack, of +-- the associated C type (eg. HsInt, HsDouble). We don't have +-- this information to hand, but we know what GHC's conventions +-- are for passing around the primitive Haskell types, so we +-- use that instead. I hope the two coincide --SDM +typeMachRep ty = argMachRep (typeCgRep ty) mkHObj :: Type -> SDoc mkHObj t = text "rts_mk" <> text (showFFIType t) @@ -590,6 +612,26 @@ Just (tc,_) -> tc Nothing -> pprPanic "showFFIType" (ppr t) +#if !defined(x86_64_TARGET_ARCH) +insertRetAddr CCallConv args = ret_addr_arg : args +insertRetAddr _ args = args +#else +-- On x86_64 we insert the return address after the 6th +-- integer argument, because this is the point at which we +-- need to flush a register argument to the stack (See rts/Adjustor.c for +-- details). +insertRetAddr CCallConv args = go 0 args + where go 6 args = ret_addr_arg : args + go n (arg@(_,_,_,rep):args) + | I64 <- rep = arg : go (n+1) args + | otherwise = arg : go n args + go n [] = [] +insertRetAddr _ args = args +#endif + +ret_addr_arg = (text "original_return_addr", text "void*", undefined, + typeMachRep addrPrimTy) + -- This function returns the primitive type associated with the boxed -- type argument to a foreign export (eg. Int ==> Int#). It assumes -- that all the types we are interested in have a single constructor