Fix a really nasty bug in SMP

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

diff --git a/ghc/compiler/cmm/CmmParse.y b/ghc/compiler/cmm/CmmParse.y
index 4b25d45..73618bc 100644 (file)
--- a/ghc/compiler/cmm/CmmParse.y
+++ b/ghc/compiler/cmm/CmmParse.y
@@ -32,12 +32,14 @@ import MachOp
 import SMRep           ( fixedHdrSize, CgRep(..) )
 import Lexer
 
-import ForeignCall     ( CCallConv(..) )
+import ForeignCall     ( CCallConv(..), Safety(..) )
 import Literal         ( mkMachInt )
 import Unique
 import UniqFM
 import SrcLoc
-import CmdLineOpts     ( DynFlags, DynFlag(..), opt_SccProfilingOn )
+import DynFlags                ( DynFlags, DynFlag(..) )
+import Packages                ( HomeModules )
+import StaticFlags     ( opt_SccProfilingOn )
 import ErrUtils                ( printError, dumpIfSet_dyn, showPass )
 import StringBuffer    ( hGetStringBuffer )
 import FastString
@@ -46,6 +48,7 @@ import Constants      ( wORD_SIZE )
 import Outputable
 
 import Monad           ( when )
+import Data.Char       ( ord )
 
 #include "HsVersions.h"
 }
@@ -175,7 +178,7 @@ static      :: { ExtFCode [CmmStatic] }
                             return [CmmStaticLit (getLit e)] }
        | type ';'                      { return [CmmUninitialised
                                                        (machRepByteWidth $1)] }
-        | 'bits8' '[' ']' STRING ';'   { return [CmmString $4] }
+        | 'bits8' '[' ']' STRING ';'   { return [mkString $4] }
         | 'bits8' '[' INT ']' ';'      { return [CmmUninitialised 
                                                        (fromIntegral $3)] }
         | typenot8 '[' INT ']' ';'     { return [CmmUninitialised 
@@ -186,7 +189,7 @@ static      :: { ExtFCode [CmmStatic] }
                { do lits <- sequence $4;
                     return $ map CmmStaticLit $
                       mkStaticClosure (mkRtsInfoLabelFS $3) 
-                        dontCareCCS (map getLit lits) [] [] }
+                        dontCareCCS (map getLit lits) [] [] [] }
        -- arrays of closures required for the CHARLIKE & INTLIKE arrays
 
 lits   :: { [ExtFCode CmmExpr] }
@@ -293,6 +296,7 @@ bool_op :: { ExtFCode BoolExpr }
 -- This is not C-- syntax.  What to do?
 vols   :: { Maybe [GlobalReg] }
        : {- empty -}                   { Nothing }
+       | '[' ']'                       { Just [] }
        | '[' globals ']'               { Just $2 }
 
 globals :: { [GlobalReg] }
@@ -424,6 +428,9 @@ section "rodata" = ReadOnlyData
 section "bss"   = UninitialisedData
 section s       = OtherSection s
 
+mkString :: String -> CmmStatic
+mkString s = CmmString (map (fromIntegral.ord) s)
+
 -- mkMachOp infers the type of the MachOp from the type of its first
 -- argument.  We assume that this is correct: for MachOps that don't have
 -- symmetrical args (e.g. shift ops), the first arg determines the type of
@@ -457,8 +464,10 @@ exprOp name args_code =
 exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
 exprMacros = listToUFM [
   ( FSLIT("ENTRY_CODE"),   \ [x] -> entryCode x ),
-  ( FSLIT("GET_ENTRY"),    \ [x] -> entryCode (closureInfoPtr x) ),
+  ( FSLIT("INFO_PTR"),     \ [x] -> closureInfoPtr x ),
   ( FSLIT("STD_INFO"),     \ [x] -> infoTable x ),
+  ( FSLIT("FUN_INFO"),     \ [x] -> funInfoTable x ),
+  ( FSLIT("GET_ENTRY"),    \ [x] -> entryCode (closureInfoPtr x) ),
   ( FSLIT("GET_STD_INFO"), \ [x] -> infoTable (closureInfoPtr x) ),
   ( FSLIT("GET_FUN_INFO"), \ [x] -> funInfoTable (closureInfoPtr x) ),
   ( FSLIT("INFO_TYPE"),    \ [x] -> infoTableClosureType x ),
@@ -712,7 +721,7 @@ funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
 staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
 staticClosure cl_label info payload
   = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits
-  where  lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] []
+  where  lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] []
 
 foreignCall
        :: String
@@ -725,7 +734,8 @@ foreignCall "C" results_code expr_code args_code vols
        results <- sequence results_code
        expr <- expr_code
        args <- sequence args_code
-       stmtEC (CmmCall (CmmForeignCall expr CCallConv) results args vols)
+        code (emitForeignCall' PlayRisky results 
+                 (CmmForeignCall expr CCallConv) args vols)
 foreignCall conv _ _ _ _
   = fail ("unknown calling convention: " ++ conv)
 
@@ -860,8 +870,8 @@ initEnv = listToUFM [
         CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) )
   ]
 
-parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
-parseCmmFile dflags filename = do
+parseCmmFile :: DynFlags -> HomeModules -> FilePath -> IO (Maybe Cmm)
+parseCmmFile dflags hmods filename = do
   showPass dflags "ParseCmm"
   buf <- hGetStringBuffer filename
   let
@@ -872,10 +882,9 @@ parseCmmFile dflags filename = do
   case unP cmmParse init_state of
     PFailed span err -> do printError span err; return Nothing
     POk _ code -> do
-       cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
+       cmm <- initC dflags hmods no_module (getCmm (unEC code initEnv [] >> return ()))
        dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
        return (Just cmm)
   where
        no_module = panic "parseCmmFile: no module"
-
 }