Add some more generic (en|de)code(Double|Float) code

[ghc-hetmet.git] / compiler / cmm / CmmParse.y

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 1917055..37e17ca 100644 (file)
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -54,6 +54,7 @@ import Constants
 import Outputable
 
 import Control.Monad
+import Data.Array
 import Data.Char       ( ord )
 import System.Exit
 
@@ -199,7 +200,9 @@ static      :: { ExtFCode [CmmStatic] }
        | '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
 
@@ -469,10 +472,10 @@ cmm_kind_exprs :: { [ExtFCode CmmActual] }
        | 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 -}                   { [] }
@@ -496,10 +499,10 @@ cmm_formals :: { [ExtFCode CmmFormal] }
        | 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;
@@ -760,6 +763,7 @@ stmtMacros = listToUFM [
   ( 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)])
 
@@ -909,15 +913,29 @@ foreignCall conv_string results_code expr_code args_code vols safety ret
           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