- -> [ExtFCode (CmmExpr,MachHint)]
- -> Maybe [GlobalReg] -> P ExtCode
-foreignCall "C" results_code expr_code args_code vols
- = return $ do
- results <- sequence results_code
- expr <- expr_code
- args <- sequence args_code
- code (emitForeignCall' PlayRisky results
- (CmmForeignCall expr CCallConv) args vols)
-foreignCall conv _ _ _ _
- = fail ("unknown calling convention: " ++ conv)
+ -> [ExtFCode CmmActual]
+ -> Maybe [GlobalReg]
+ -> CmmSafety
+ -> CmmReturnInfo
+ -> P ExtCode
+foreignCall conv_string results_code expr_code args_code vols safety ret
+ = do convention <- case conv_string of
+ "C" -> return CCallConv
+ "stdcall" -> return StdCallConv
+ "C--" -> return CmmCallConv
+ _ -> fail ("unknown calling convention: " ++ conv_string)
+ return $ do
+ results <- sequence results_code
+ expr <- expr_code
+ args <- sequence args_code
+ --code (stmtC (CmmCall (CmmCallee expr convention) results args safety))
+ case convention of
+ -- Temporary hack so at least some functions are CmmSafe
+ CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety ret))
+ _ ->
+ let expr' = adjCallTarget convention expr args in
+ case safety of
+ CmmUnsafe ->
+ code (emitForeignCall' PlayRisky results
+ (CmmCallee expr' convention) args vols NoC_SRT ret)
+ CmmSafe srt ->
+ code (emitForeignCall' (PlaySafe unused) results
+ (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