Implemented and fixed bugs in CmmInfo handling
[ghc.git] / compiler / cmm / CmmParse.y
index 0701b4c..840b564 100644 (file)
@@ -1,6 +1,6 @@
 -----------------------------------------------------------------------------
 --
--- (c) The University of Glasgow, 2004
+-- (c) The University of Glasgow, 2004-2006
 --
 -- Parser for concrete Cmm.
 --
@@ -16,39 +16,39 @@ import CgProf
 import CgTicky
 import CgInfoTbls
 import CgForeignCall
-import CgTailCall      ( pushUnboxedTuple )
-import CgStackery      ( emitPushUpdateFrame )
-import ClosureInfo     ( C_SRT(..) )
-import CgCallConv      ( smallLiveness )
-import CgClosure       ( emitBlackHoleCode )
-import CostCentre      ( dontCareCCS )
+import CgTailCall
+import CgStackery
+import ClosureInfo
+import CgCallConv
+import CgClosure
+import CostCentre
 
 import Cmm
 import PprCmm
-import CmmUtils                ( mkIntCLit )
+import CmmUtils
 import CmmLex
 import CLabel
 import MachOp
-import SMRep           ( fixedHdrSize, CgRep(..) )
+import SMRep
 import Lexer
 
-import ForeignCall     ( CCallConv(..), Safety(..) )
-import Literal         ( mkMachInt )
+import ForeignCall
+import Literal
 import Unique
 import UniqFM
 import SrcLoc
-import DynFlags                ( DynFlags, DynFlag(..) )
-import Packages                ( HomeModules )
-import StaticFlags     ( opt_SccProfilingOn )
-import ErrUtils                ( printError, dumpIfSet_dyn, showPass )
-import StringBuffer    ( hGetStringBuffer )
+import DynFlags
+import StaticFlags
+import ErrUtils
+import StringBuffer
 import FastString
-import Panic           ( panic )
-import Constants       ( wORD_SIZE )
+import Panic
+import Constants
 import Outputable
 
-import Monad           ( when )
+import Control.Monad
 import Data.Char       ( ord )
+import System.Exit
 
 #include "HsVersions.h"
 }
@@ -103,6 +103,8 @@ import Data.Char    ( ord )
        'if'            { L _ (CmmT_if) }
        'jump'          { L _ (CmmT_jump) }
        'foreign'       { L _ (CmmT_foreign) }
+       'prim'          { L _ (CmmT_prim) }
+       'return'        { L _ (CmmT_return) }
        'import'        { L _ (CmmT_import) }
        'switch'        { L _ (CmmT_switch) }
        'case'          { L _ (CmmT_case) }
@@ -197,44 +199,73 @@ lits      :: { [ExtFCode CmmExpr] }
        | ',' expr lits         { $2 : $3 }
 
 cmmproc :: { ExtCode }
-       : info '{' body '}'
-               { do  (info_lbl, info1, info2) <- $1;
-                     stmts <- getCgStmtsEC (loopDecls $3)
-                     blks <- code (cgStmtsToBlocks stmts)
-                     code (emitInfoTableAndCode info_lbl info1 info2 [] blks) }
-
-       | info ';'
-               { do (info_lbl, info1, info2) <- $1;
-                    code (emitInfoTableAndCode info_lbl info1 info2 [] []) }
-
-       | NAME '{' body '}'
-               { do stmts <- getCgStmtsEC (loopDecls $3);
+-- TODO: add real SRT/info tables to parsed Cmm
+       : info maybe_formals '{' body '}'
+               { do (info_lbl, info) <- $1;
+                    formals <- sequence $2;
+                    stmts <- getCgStmtsEC (loopDecls $4)
                     blks <- code (cgStmtsToBlocks stmts)
-                    code (emitProc [] (mkRtsCodeLabelFS $1) [] blks) }
+                    code (emitInfoTableAndCode info_lbl info formals blks) }
 
-info   :: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
+       | info maybe_formals ';'
+               { do (info_lbl, info) <- $1;
+                    formals <- sequence $2;
+                    code (emitInfoTableAndCode info_lbl info formals []) }
+
+       | NAME maybe_formals '{' body '}'
+               { do formals <- sequence $2;
+                    stmts <- getCgStmtsEC (loopDecls $4);
+                    blks <- code (cgStmtsToBlocks stmts);
+                    code (emitProc (CmmNonInfo Nothing) (mkRtsCodeLabelFS $1) formals blks) }
+
+info   :: { ExtFCode (CLabel, CmmInfo) }
        : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
                -- ptrs, nptrs, closure type, description, type
-               { stdInfo $3 $5 $7 0 $9 $11 $13 }
+               { do prof <- profilingInfo $11 $13
+                    return (mkRtsInfoLabelFS $3,
+                       CmmInfo prof Nothing (fromIntegral $9)
+                               (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT)) }
        
        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
                -- ptrs, nptrs, closure type, description, type, fun type
-               { funInfo $3 $5 $7 $9 $11 $13 $15 }
+               { do prof <- profilingInfo $11 $13
+                    return (mkRtsInfoLabelFS $3,
+                       CmmInfo prof Nothing (fromIntegral $9)
+                               (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
+                                (ArgSpec 0)
+                                zeroCLit)) }
+               -- we leave most of the fields zero here.  This is only used
+               -- to generate the BCO info table in the RTS at the moment.
        
        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
                -- ptrs, nptrs, tag, closure type, description, type
-               { stdInfo $3 $5 $7 $9 $11 $13 $15 }
+               { do prof <- profilingInfo $13 $15
+                    -- If profiling is on, this string gets duplicated,
+                    -- but that's the way the old code did it we can fix it some other time.
+                    desc_lit <- code $ mkStringCLit $13
+                    return (mkRtsInfoLabelFS $3,
+                       CmmInfo prof Nothing (fromIntegral $11)
+                               (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit)) }
        
        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
                -- selector, closure type, description, type
-               { basicInfo $3 (mkIntCLit (fromIntegral $5)) 0 $7 $9 $11 }
-
-       | 'INFO_TABLE_RET' '(' NAME ',' INT ',' INT ',' INT maybe_vec ')'
-               { retInfo $3 $5 $7 $9 $10 }
-
-maybe_vec :: { [CmmLit] }
-       : {- empty -}                   { [] }
-       | ',' NAME maybe_vec            { CmmLabel (mkRtsCodeLabelFS $2) : $3 }
+               { do prof <- profilingInfo $9 $11
+                    return (mkRtsInfoLabelFS $3,
+                       CmmInfo prof Nothing (fromIntegral $7)
+                               (ThunkSelectorInfo (fromIntegral $5) NoC_SRT)) }
+
+       | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
+               -- closure type (no live regs)
+               { return (mkRtsInfoLabelFS $3,
+                       CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5)
+                               (ContInfo [] NoC_SRT)) }
+
+       | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
+               -- closure type, live regs
+               { do live <- sequence (map (liftM Just) $7)
+                    return (mkRtsInfoLabelFS $3,
+                       CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5)
+                       (ContInfo live NoC_SRT)) }
 
 body   :: { ExtCode }
        : {- empty -}                   { return () }
@@ -242,7 +273,10 @@ body       :: { ExtCode }
        | stmt body                     { do $1; $2 }
 
 decl   :: { ExtCode }
-       : type names ';'                { mapM_ (newLocal $1) $2 }
+       : type names ';'                { mapM_ (newLocal defaultKind $1) $2 }
+       | STRING type names ';'         {% do k <- parseKind $1;
+                                             return $ mapM_ (newLocal k $2) $3 }
+
        | 'import' names ';'            { return () }  -- ignore imports
        | 'export' names ';'            { return () }  -- ignore exports
 
@@ -256,19 +290,21 @@ stmt      :: { ExtCode }
        | NAME ':'
                { do l <- newLabel $1; code (labelC l) }
 
-       | lreg '=' expr ';'                     
+       | lreg '=' expr ';'
                { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
        | type '[' expr ']' '=' expr ';'
                { doStore $1 $3 $6 }
-       | 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
-               {% foreignCall $2 [] $3 $5 $7 }
-       | lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
-               {% let result = do r <- $1; return (r,NoHint) in
-                  foreignCall $4 [result] $5 $7 $9 }
-       | STRING lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
-               {% do h <- parseHint $1;
-                     let result = do r <- $2; return (r,h) in
-                     foreignCall $5 [result] $6 $8 $10 }
+
+       -- Gah! We really want to say "maybe_results" but that causes
+       -- a shift/reduce conflict with assignment.  We either
+       -- we expand out the no-result and single result cases or
+       -- we tweak the syntax to avoid the conflict.  The later
+       -- option is taken here because the other way would require
+       -- multiple levels of expanding and get unwieldy.
+       | maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
+               {% foreignCall $3 $1 $4 $6 $8 NoC_SRT }
+       | maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
+               {% primCall $1 $4 $6 $8 NoC_SRT }
        -- stmt-level macros, stealing syntax from ordinary C-- function calls.
        -- Perhaps we ought to use the %%-form?
        | NAME '(' exprs0 ')' ';'
@@ -277,8 +313,10 @@ stmt       :: { ExtCode }
                { doSwitch $2 $3 $5 $6 }
        | 'goto' NAME ';'
                { do l <- lookupLabel $2; stmtEC (CmmBranch l) }
-       | 'jump' expr {-maybe_actuals-} ';'
-               { do e <- $2; stmtEC (CmmJump e []) }
+       | 'jump' expr maybe_actuals ';'
+               { do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
+        | 'return' maybe_actuals ';'
+               { do e <- sequence $2; stmtEC (CmmReturn e) }
        | 'if' bool_expr '{' body '}' else      
                { ifThenElse $2 $4 $6 }
 
@@ -370,6 +408,10 @@ maybe_ty :: { MachRep }
        : {- empty -}                   { wordRep }
        | '::' type                     { $2 }
 
+maybe_actuals :: { [ExtFCode (CmmExpr, MachHint)] }
+       : {- empty -}           { [] }
+       | '(' hint_exprs0 ')'   { $2 }
+
 hint_exprs0 :: { [ExtFCode (CmmExpr, MachHint)] }
        : {- empty -}                   { [] }
        | hint_exprs                    { $1 }
@@ -396,6 +438,28 @@ reg        :: { ExtFCode CmmExpr }
        : NAME                  { lookupName $1 }
        | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
 
+maybe_results :: { [ExtFCode (CmmFormal, MachHint)] }
+       : {- empty -}           { [] }
+       | '(' hint_lregs ')' '='        { $2 }
+
+hint_lregs :: { [ExtFCode (CmmFormal, MachHint)] }
+       : hint_lreg                     { [$1] }
+       | hint_lreg ','                 { [$1] }
+       | hint_lreg ',' hint_lregs      { $1 : $3 }
+
+hint_lreg :: { ExtFCode (CmmFormal, MachHint) }
+       : local_lreg                    { do e <- $1; return (e, inferHint (CmmReg (CmmLocal e))) }
+       | STRING local_lreg             {% do h <- parseHint $1;
+                                             return $ do
+                                               e <- $2; return (e,h) }
+
+local_lreg :: { ExtFCode LocalReg }
+       : NAME                  { do e <- lookupName $1;
+                                    return $
+                                      case e of 
+                                       CmmReg (CmmLocal r) -> r
+                                       other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
+
 lreg   :: { ExtFCode CmmReg }
        : NAME                  { do e <- lookupName $1;
                                     return $
@@ -404,6 +468,24 @@ lreg       :: { ExtFCode CmmReg }
                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
        | GLOBALREG             { return (CmmGlobal $1) }
 
+maybe_formals :: { [ExtFCode LocalReg] }
+       : {- empty -}           { [] }
+       | '(' formals0 ')'      { $2 }
+
+formals0 :: { [ExtFCode LocalReg] }
+       : {- empty -}           { [] }
+       | formals               { $1 }
+
+formals :: { [ExtFCode LocalReg] }
+       : formal ','            { [$1] }
+       | formal                { [$1] }
+       | formal ',' formals    { $1 : $3 }
+
+formal :: { ExtFCode LocalReg }
+       : type NAME             { newLocal defaultKind $1 $2 }
+       | STRING type NAME      {% do k <- parseKind $1;
+                                    return $ newLocal k $2 $3 }
+
 type   :: { MachRep }
        : 'bits8'               { I8 }
        | typenot8              { $1 }
@@ -419,6 +501,7 @@ section :: String -> Section
 section "text"  = Text
 section "data"          = Data
 section "rodata" = ReadOnlyData
+section "relrodata" = RelocatableReadOnlyData
 section "bss"   = UninitialisedData
 section s       = OtherSection s
 
@@ -466,8 +549,7 @@ exprMacros = listToUFM [
   ( FSLIT("GET_FUN_INFO"), \ [x] -> funInfoTable (closureInfoPtr x) ),
   ( FSLIT("INFO_TYPE"),    \ [x] -> infoTableClosureType x ),
   ( FSLIT("INFO_PTRS"),    \ [x] -> infoTablePtrs x ),
-  ( FSLIT("INFO_NPTRS"),   \ [x] -> infoTableNonPtrs x ),
-  ( FSLIT("RET_VEC"),      \ [info, conZ] -> retVec info conZ )
+  ( FSLIT("INFO_NPTRS"),   \ [x] -> infoTableNonPtrs x )
   ]
 
 -- we understand a subset of C-- primitives:
@@ -523,19 +605,32 @@ machOps = listToUFM $
        ( "f2f32",    flip MO_S_Conv F32 ),  -- TODO; rounding mode
        ( "f2f64",    flip MO_S_Conv F64 ),  -- TODO; rounding mode
        ( "f2i8",     flip MO_S_Conv I8 ),
-       ( "f2i16",    flip MO_S_Conv I8 ),
-       ( "f2i32",    flip MO_S_Conv I8 ),
-       ( "f2i64",    flip MO_S_Conv I8 ),
+       ( "f2i16",    flip MO_S_Conv I16 ),
+       ( "f2i32",    flip MO_S_Conv I32 ),
+       ( "f2i64",    flip MO_S_Conv I64 ),
        ( "i2f32",    flip MO_S_Conv F32 ),
        ( "i2f64",    flip MO_S_Conv F64 )
        ]
 
+callishMachOps = listToUFM $
+       map (\(x, y) -> (mkFastString x, y)) [
+        ( "write_barrier", MO_WriteBarrier )
+        -- ToDo: the rest, maybe
+    ]
+
 parseHint :: String -> P MachHint
 parseHint "ptr"    = return PtrHint
 parseHint "signed" = return SignedHint
 parseHint "float"  = return FloatHint
 parseHint str      = fail ("unrecognised hint: " ++ str)
 
+parseKind :: String -> P Kind
+parseKind "ptr"    = return KindPtr
+parseKind str      = fail ("unrecognized kin: " ++ str)
+
+defaultKind :: Kind
+defaultKind = KindNonPtr
+
 -- labels are always pointers, so we might as well infer the hint
 inferHint :: CmmExpr -> MachHint
 inferHint (CmmLit (CmmLabel _)) = PtrHint
@@ -599,6 +694,7 @@ stmtMacros = listToUFM [
   ( FSLIT("RET_NN"),   \[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
   ( FSLIT("RET_NP"),   \[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
   ( 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_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)])
@@ -649,10 +745,12 @@ addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ())
 addLabel :: FastString -> BlockId -> ExtCode
 addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ())
 
-newLocal :: MachRep -> FastString -> ExtCode
-newLocal ty name  = do
+newLocal :: Kind -> MachRep -> FastString -> ExtFCode LocalReg
+newLocal kind ty name = do
    u <- code newUnique
-   addVarDecl name (CmmReg (CmmLocal (LocalReg u ty)))
+   let reg = LocalReg u ty kind
+   addVarDecl name (CmmReg (CmmLocal reg))
+   return reg
 
 newLabel :: FastString -> ExtFCode BlockId
 newLabel name = do
@@ -696,38 +794,15 @@ forkLabelledCodeEC ec = do
   stmts <- getCgStmtsEC ec
   code (forkCgStmts stmts)
 
-retInfo name size live_bits cl_type vector = do
-  let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
-      info_lbl = mkRtsRetInfoLabelFS name
-      (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT 
-                               (fromIntegral cl_type) vector
-  return (info_lbl, info1, info2)
 
-stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
-  basicInfo name (packHalfWordsCLit ptrs nptrs) 
-       srt_bitmap cl_type desc_str ty_str
-
-basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
+profilingInfo desc_str ty_str = do
   lit1 <- if opt_SccProfilingOn 
                   then code $ mkStringCLit desc_str
                   else return (mkIntCLit 0)
   lit2 <- if opt_SccProfilingOn 
                   then code $ mkStringCLit ty_str
                   else return (mkIntCLit 0)
-  let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type) 
-                       (fromIntegral srt_bitmap)
-                       layout
-  return (mkRtsInfoLabelFS name, info1, [])
-
-funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
-  (label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-}
-                        cl_type desc_str ty_str 
-  let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero
-               -- we leave most of the fields zero here.  This is only used
-               -- to generate the BCO info table in the RTS at the moment.
-  return (label,info1,info2)
- where
-   zero = mkIntCLit 0
+  return (ProfilingInfo lit1 lit2)
 
 
 staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
@@ -737,19 +812,38 @@ staticClosure cl_label info payload
 
 foreignCall
        :: String
-       -> [ExtFCode (CmmReg,MachHint)]
+       -> [ExtFCode (CmmFormal,MachHint)]
        -> ExtFCode CmmExpr
        -> [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)
+       -> Maybe [GlobalReg]
+        -> C_SRT
+        -> P ExtCode
+foreignCall conv_string results_code expr_code args_code vols srt
+  = do  convention <- case conv_string of
+          "C" -> return CCallConv
+          "C--" -> return CmmCallConv
+          _ -> fail ("unknown calling convention: " ++ conv_string)
+       return $ do
+         results <- sequence results_code
+         expr <- expr_code
+         args <- sequence args_code
+          code (emitForeignCall' PlayRisky results 
+                 (CmmForeignCall expr convention) args vols srt) where
+
+primCall
+       :: [ExtFCode (CmmFormal,MachHint)]
+       -> FastString
+       -> [ExtFCode (CmmExpr,MachHint)]
+       -> Maybe [GlobalReg]
+        -> C_SRT
+        -> P ExtCode
+primCall results_code name args_code vols srt
+  = case lookupUFM callishMachOps name of
+       Nothing -> fail ("unknown primitive " ++ unpackFS name)
+       Just p  -> return $ do
+               results <- sequence results_code
+               args <- sequence args_code
+               code (emitForeignCall' PlayRisky results (CmmPrim p) args vols srt)
 
 doStore :: MachRep -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 doStore rep addr_code val_code
@@ -773,6 +867,7 @@ emitRetUT args = do
   emitStmts stmts
   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
+  -- TODO (when using CPS): emitStmt (CmmReturn (map snd args))
 
 -- -----------------------------------------------------------------------------
 -- If-then-else and boolean expressions
@@ -882,8 +977,8 @@ initEnv = listToUFM [
     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) ))
   ]
 
-parseCmmFile :: DynFlags -> HomeModules -> FilePath -> IO (Maybe Cmm)
-parseCmmFile dflags hmods filename = do
+parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
+parseCmmFile dflags filename = do
   showPass dflags "ParseCmm"
   buf <- hGetStringBuffer filename
   let
@@ -893,9 +988,12 @@ parseCmmFile dflags hmods filename = do
                -- in there we don't want.
   case unP cmmParse init_state of
     PFailed span err -> do printError span err; return Nothing
-    POk _ code -> do
-       cmm <- initC dflags hmods no_module (getCmm (unEC code initEnv [] >> return ()))
-       dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
+    POk pst code -> do
+       cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
+       let ms = getMessages pst
+       printErrorsAndWarnings dflags ms
+        when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
+        dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
        return (Just cmm)
   where
        no_module = panic "parseCmmFile: no module"