Implemented and fixed bugs in CmmInfo handling
[ghc.git] / compiler / cmm / CmmParse.y
index 6048c44..840b564 100644 (file)
@@ -199,44 +199,73 @@ lits      :: { [ExtFCode CmmExpr] }
        | ',' expr lits         { $2 : $3 }
 
 cmmproc :: { ExtCode }
+-- TODO: add real SRT/info tables to parsed Cmm
        : info maybe_formals '{' body '}'
-               { do (info_lbl, info1, info2) <- $1;
+               { do (info_lbl, info) <- $1;
                     formals <- sequence $2;
                     stmts <- getCgStmtsEC (loopDecls $4)
                     blks <- code (cgStmtsToBlocks stmts)
-                    code (emitInfoTableAndCode info_lbl info1 info2 formals blks) }
+                    code (emitInfoTableAndCode info_lbl info formals blks) }
 
        | info maybe_formals ';'
-               { do (info_lbl, info1, info2) <- $1;
+               { do (info_lbl, info) <- $1;
                     formals <- sequence $2;
-                    code (emitInfoTableAndCode info_lbl info1 info2 formals []) }
+                    code (emitInfoTableAndCode info_lbl info formals []) }
 
        | NAME maybe_formals '{' body '}'
                { do formals <- sequence $2;
                     stmts <- getCgStmtsEC (loopDecls $4);
                     blks <- code (cgStmtsToBlocks stmts);
-                    code (emitProc [] (mkRtsCodeLabelFS $1) formals blks) }
+                    code (emitProc (CmmNonInfo Nothing) (mkRtsCodeLabelFS $1) formals blks) }
 
-info   :: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
+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 ')'
-               -- size, live bits, closure type
-               { 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 () }
@@ -244,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
 
@@ -258,16 +290,21 @@ stmt      :: { ExtCode }
        | NAME ':'
                { do l <- newLabel $1; code (labelC l) }
 
--- HACK: this should just be lregs but that causes a shift/reduce conflict
--- with foreign calls
---     | hint_lregs '=' expr ';'
---             { do reg <- head $1; e <- $3; stmtEC (CmmAssign (fst reg) e) }
+       | lreg '=' expr ';'
+               { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
        | type '[' expr ']' '=' expr ';'
                { doStore $1 $3 $6 }
+
+       -- 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 }
+               {% foreignCall $3 $1 $4 $6 $8 NoC_SRT }
        | maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
-               {% primCall $1 $4 $6 $8 }
+               {% 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 ')' ';'
@@ -401,21 +438,28 @@ reg       :: { ExtFCode CmmExpr }
        : NAME                  { lookupName $1 }
        | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
 
-maybe_results :: { [ExtFCode (CmmReg, MachHint)] }
+maybe_results :: { [ExtFCode (CmmFormal, MachHint)] }
        : {- empty -}           { [] }
-       | hint_lregs '='        { $1 }
+       | '(' hint_lregs ')' '='        { $2 }
 
-hint_lregs :: { [ExtFCode (CmmReg, MachHint)] }
-       : hint_lreg ','                 { [$1] }
-       | hint_lreg                     { [$1] }
+hint_lregs :: { [ExtFCode (CmmFormal, MachHint)] }
+       : hint_lreg                     { [$1] }
+       | hint_lreg ','                 { [$1] }
        | hint_lreg ',' hint_lregs      { $1 : $3 }
 
-hint_lreg :: { ExtFCode (CmmReg, MachHint) }
-       : lreg                          { do e <- $1; return (e, inferHint (CmmReg e)) }
-       | STRING lreg                   {% do h <- parseHint $1;
+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 $
@@ -580,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
@@ -694,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
@@ -741,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
@@ -792,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
@@ -806,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
@@ -843,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