[commit: ghc] wip/kavon-nosplit-llvm: storing retTy in cg state monad (305cec6)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/kavon-nosplit-llvm
Link       : http://ghc.haskell.org/trac/ghc/changeset/305cec6fc8fd85c99abd25dc58d12eb76a617e28/ghc

>---------------------------------------------------------------

commit 305cec6fc8fd85c99abd25dc58d12eb76a617e28
Author: Kavon Farvardin <kavon at farvard.in>
Date:   Thu Aug 24 16:29:50 2017 -0500

    storing retTy in cg state monad


>---------------------------------------------------------------

305cec6fc8fd85c99abd25dc58d12eb76a617e28
 compiler/cmm/Cmm.hs             |  4 +++-
 compiler/codeGen/StgCmmBind.hs  | 11 +++++++++--
 compiler/codeGen/StgCmmMonad.hs | 19 ++++++++++++++++++-
 3 files changed, 30 insertions(+), 4 deletions(-)

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index b77688c..0ec516c 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -6,7 +6,7 @@ module Cmm (
      CmmProgram, CmmGroup, GenCmmGroup,
      CmmDecl, GenCmmDecl(..),
      CmmGraph, GenCmmGraph(..),
-     CmmBlock,
+     CmmBlock, CmmRetTy,
      RawCmmDecl, RawCmmGroup,
      Section(..), SectionType(..), CmmStatics(..), CmmStatic(..),
      isSecConstant,
@@ -59,6 +59,8 @@ type GenCmmGroup d h g = [GenCmmDecl d h g]
 type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
 type RawCmmGroup = GenCmmGroup CmmStatics (LabelMap CmmStatics) CmmGraph
 
+type CmmRetTy = Maybe [CmmType]
+
 -----------------------------------------------------------------------------
 --  CmmDecl, GenCmmDecl
 -----------------------------------------------------------------------------
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 9875b8d..dfdac74 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -508,12 +508,18 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
                 -- heap check, to reduce live vars over check
                 ; when node_points $ load_fvs node lf_info fv_bindings
                 ; retKind <- cgExpr body
-                ; let !x = trace (retK2s retKind) ()
+                ; saveRetKind retKind
+                -- ; let !x = trace (retK2s retKind) ()
                 ; return ()
                 }}}
 
   }
   
+saveRetKind :: ReturnKind -> FCode ()
+saveRetKind (Returning tys)  = updateRetTy $ Just tys
+saveRetKind AssignedDirectly = updateRetTy Nothing
+saveRetKind (ReturnedTo _ _ _) = panic "saveRetKind"
+
 -- start of temporary debugging utils --
 
 retK2s :: ReturnKind -> String  
@@ -607,7 +613,8 @@ thunkCode cl_info fv_details _cc node arity body
                ; fv_bindings <- mapM bind_fv fv_details
                ; load_fvs node lf_info fv_bindings
                ; retKind <- cgExpr body
-               ; let !x = trace (retK2s retKind) ()
+               ; saveRetKind retKind
+            --    ; let !x = trace (retK2s retKind) ()
                ; return ()
                }}}
 
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 05be4fd..d950d48 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -36,6 +36,7 @@ module StgCmmMonad (
 
         Sequel(..), ReturnKind(..),
         withSequel, getSequel, combineReturnKinds,
+        updateRetTy, getRetTy,
 
         setTickyCtrLabel, getTickyCtrLabel,
         tickScope, getTickScope,
@@ -265,7 +266,7 @@ data ReturnKind
 combineReturnKinds :: [ReturnKind] -> ReturnKind
 combineReturnKinds rks = foldl combine AssignedDirectly rks
     where
-        combine (Returning a) (Returning b) = Returning $ tryCheck a b
+        combine (Returning a) (Returning b) = Returning $ check a b
         combine _             (Returning b) = Returning b
         combine acc           _             = acc
         
@@ -382,6 +383,8 @@ data CgState
   = MkCgState {
      cgs_stmts :: CmmAGraph,          -- Current procedure
      
+     cgs_ret_ty :: CmmRetTy,          -- Current procedure's return type.
+
      cgs_tops  :: OrdList CmmDecl,
         -- Other procedures and data blocks in this compilation unit
         -- Both are ordered only so that we can
@@ -438,6 +441,7 @@ Hp register.  (Changing virtHp doesn't matter.)
 initCgState :: UniqSupply -> CgState
 initCgState uniqs
   = MkCgState { cgs_stmts  = mkNop
+              , cgs_ret_ty = Nothing
               , cgs_tops   = nilOL
               , cgs_binds  = emptyVarEnv
               , cgs_hp_usg = initHpUsage
@@ -519,6 +523,18 @@ setBinds new_binds = do
         state <- getState
         setState $ state {cgs_binds = new_binds}
         
+getRetTy :: FCode CmmRetTy
+getRetTy = do
+        state <- getState
+        return $ cgs_ret_ty state
+
+updateRetTy :: CmmRetTy -> FCode ()
+updateRetTy new_ty = do
+        state <- getState
+        case cgs_ret_ty state of
+            Nothing -> setState $ state {cgs_ret_ty = new_ty}
+            Just _ -> panic "updateRetTy: already have retTy info" 
+
 withState :: FCode a -> CgState -> FCode (a,CgState)
 withState (FCode fcode) newstate = FCode $ \info_down state ->
   case fcode info_down newstate of
@@ -848,6 +864,7 @@ emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
 emitProc_ mb_info lbl live blocks offset do_layout
   = do  { dflags <- getDynFlags
         ; l <- newBlockId
+        ; retTy <- getRetTy
         ; let
               blks = labelAGraph l blocks