import Outputable
import Control.Monad
+import Data.Array
import Data.Char ( ord )
import System.Exit
| 'CLOSURE' '(' NAME lits ')'
{ do lits <- sequence $4;
return $ map CmmStaticLit $
- mkStaticClosure (mkRtsInfoLabelFS $3)
+ mkStaticClosure (mkForeignLabel $3 Nothing True)
+ -- mkForeignLabel because these are only used
+ -- for CHARLIKE and INTLIKE closures in the RTS.
dontCareCCS (map getLit lits) [] [] [] }
-- arrays of closures required for the CHARLIKE & INTLIKE arrays
| cmm_kind_expr ',' cmm_kind_exprs { $1 : $3 }
cmm_kind_expr :: { ExtFCode CmmActual }
- : expr { do e <- $1; return (e, inferCmmKind e) }
+ : expr { do e <- $1; return (CmmHinted e (inferCmmKind e)) }
| expr STRING {% do h <- parseCmmKind $2;
return $ do
- e <- $1; return (e,h) }
+ e <- $1; return (CmmHinted e h) }
exprs0 :: { [ExtFCode CmmExpr] }
: {- empty -} { [] }
| cmm_formal ',' cmm_formals { $1 : $3 }
cmm_formal :: { ExtFCode CmmFormal }
- : local_lreg { do e <- $1; return (e, inferCmmKind (CmmReg (CmmLocal e))) }
+ : local_lreg { do e <- $1; return (CmmHinted e (inferCmmKind (CmmReg (CmmLocal e)))) }
| STRING local_lreg {% do h <- parseCmmKind $1;
return $ do
- e <- $2; return (e,h) }
+ e <- $2; return (CmmHinted e h) }
local_lreg :: { ExtFCode LocalReg }
: NAME { do e <- lookupName $1;
( FSLIT("RET_PPP"), \[a,b,c] -> emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
( FSLIT("RET_NPP"), \[a,b,c] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
( FSLIT("RET_NNP"), \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
+ ( FSLIT("RET_NNN"), \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c)]),
( FSLIT("RET_NNNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
( FSLIT("RET_NPNP"), \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
case convention of
-- Temporary hack so at least some functions are CmmSafe
CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety ret))
- _ -> case safety of
+ _ ->
+ let expr' = adjCallTarget convention expr args in
+ case safety of
CmmUnsafe ->
code (emitForeignCall' PlayRisky results
- (CmmCallee expr convention) args vols NoC_SRT ret)
+ (CmmCallee expr' convention) args vols NoC_SRT ret)
CmmSafe srt ->
code (emitForeignCall' (PlaySafe unused) results
- (CmmCallee expr convention) args vols NoC_SRT ret) where
+ (CmmCallee expr' convention) args vols NoC_SRT ret) where
unused = panic "not used by emitForeignCall'"
+adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
+#ifdef mingw32_TARGET_OS
+-- On Windows, we have to add the '@N' suffix to the label when making
+-- a call with the stdcall calling convention.
+adjCallTarget StdCallConv (CmmLit (CmmLabel lbl)) args
+ = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
+ where size (CmmHinted e _) = max wORD_SIZE (machRepByteWidth (cmmExprRep e))
+ -- c.f. CgForeignCall.emitForeignCall
+#endif
+adjCallTarget _ expr _
+ = expr
+
primCall
:: [ExtFCode CmmFormal]
-> FastString