Implemented and fixed bugs in CmmInfo handling
[ghc.git] / compiler / cmm / CmmParse.y
index 3842e65..840b564 100644 (file)
@@ -199,40 +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
-               { conInfo $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 ')'
-               { retInfo $3 $5 $7 $9 }
+               { 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 () }
@@ -240,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
 
@@ -254,24 +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 }
-       | 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
-               {% primCall [] $3 $5 $7 }
-       | lreg '=' 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
-               {% let result = do r <- $1; return (r,NoHint) in
-                  primCall [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 ')' ';'
@@ -405,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 $
@@ -413,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 }
@@ -551,6 +624,13 @@ 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
@@ -665,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
@@ -712,48 +794,15 @@ forkLabelledCodeEC ec = do
   stmts <- getCgStmtsEC ec
   code (forkCgStmts stmts)
 
-retInfo name size live_bits cl_type = do
-  let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
-      info_lbl = mkRtsRetInfoLabelFS name
-      (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT 
-                               (fromIntegral cl_type)
-  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
-
-conInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str = do
-  (lbl, info1, _) <- basicInfo name (packHalfWordsCLit ptrs nptrs) 
-                       srt_bitmap cl_type desc_str ty_str
-  desc_lit <- code $ mkStringCLit desc_str
-  let desc_field = makeRelativeRefTo lbl desc_lit
-  return (lbl, info1, [desc_field])
-
-basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
-  let info_lbl = mkRtsInfoLabelFS name
+
+profilingInfo desc_str ty_str = do
   lit1 <- if opt_SccProfilingOn 
-                  then code $ do lit <- mkStringCLit desc_str
-                                  return (makeRelativeRefTo info_lbl lit)
+                  then code $ mkStringCLit desc_str
                   else return (mkIntCLit 0)
   lit2 <- if opt_SccProfilingOn 
-                  then code $ do lit <- mkStringCLit ty_str
-                                  return (makeRelativeRefTo info_lbl lit)
+                  then code $ mkStringCLit ty_str
                   else return (mkIntCLit 0)
-  let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type) 
-                       (fromIntegral srt_bitmap)
-                       layout
-  return (info_lbl, 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
@@ -763,11 +812,13 @@ staticClosure cl_label info payload
 
 foreignCall
        :: String
-       -> [ExtFCode (CmmReg,MachHint)]
+       -> [ExtFCode (CmmFormal,MachHint)]
        -> ExtFCode CmmExpr
        -> [ExtFCode (CmmExpr,MachHint)]
-       -> Maybe [GlobalReg] -> P ExtCode
-foreignCall conv_string results_code expr_code args_code vols
+       -> 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
@@ -777,20 +828,22 @@ foreignCall conv_string results_code expr_code args_code vols
          expr <- expr_code
          args <- sequence args_code
           code (emitForeignCall' PlayRisky results 
-                 (CmmForeignCall expr convention) args vols) where
+                 (CmmForeignCall expr convention) args vols srt) where
 
 primCall
-       :: [ExtFCode (CmmReg,MachHint)]
+       :: [ExtFCode (CmmFormal,MachHint)]
        -> FastString
        -> [ExtFCode (CmmExpr,MachHint)]
-       -> Maybe [GlobalReg] -> P ExtCode
-primCall results_code name args_code vols
+       -> 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)
+               code (emitForeignCall' PlayRisky results (CmmPrim p) args vols srt)
 
 doStore :: MachRep -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 doStore rep addr_code val_code
@@ -814,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