[commit: ghc] wip/libdw-unwind: StgCmmForeign: Produce unwind information in {load, save}ThreadState (b954e65)

[git at git.haskell.org]

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

On branch  : wip/libdw-unwind
Link       : http://ghc.haskell.org/trac/ghc/changeset/b954e65de5a214243eaf25355393081ef3475a41/ghc

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

commit b954e65de5a214243eaf25355393081ef3475a41
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Sat Jan 2 15:35:24 2016 +0100

    StgCmmForeign: Produce unwind information in {load,save}ThreadState
    
    This actually just gives us the *ability* to produce unwind information.
    The unwind information itself will be implemented next.


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

b954e65de5a214243eaf25355393081ef3475a41
 compiler/cmm/CmmLayoutStack.hs    |  4 ++--
 compiler/cmm/MkGraph.hs           |  5 ++++-
 compiler/codeGen/StgCmmForeign.hs | 35 +++++++++++++++++++++++++++++------
 3 files changed, 35 insertions(+), 9 deletions(-)

diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index d4a1ceb..9ea9f85 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -1008,8 +1008,8 @@ lowerSafeForeignCall dflags block
     id <- newTemp (bWord dflags)
     new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg))
     let (caller_save, caller_load) = callerSaveVolatileRegs dflags
-    save_state_code <- saveThreadState dflags
-    load_state_code <- loadThreadState dflags
+    save_state_code <- saveThreadState dflags Nothing
+    load_state_code <- loadThreadState dflags Nothing
     let suspend = save_state_code  <*>
                   caller_save <*>
                   mkMiddle (callSuspendThread dflags id intrbl)
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index 657585e..64e9dfa 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -7,7 +7,7 @@ module MkGraph
   , lgraphOfAGraph, labelAGraph
 
   , stackStubExpr
-  , mkNop, mkAssign, mkStore, mkUnsafeCall, mkFinalCall, mkCallReturnsTo
+  , mkNop, mkAssign, mkStore, mkUnwind, mkUnsafeCall, mkFinalCall, mkCallReturnsTo
   , mkJumpReturnsTo
   , mkJump, mkJumpExtra
   , mkRawJump
@@ -196,6 +196,9 @@ mkAssign l r  = mkMiddle $ CmmAssign l r
 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
 mkStore  l r  = mkMiddle $ CmmStore  l r
 
+mkUnwind     :: NewOrExistingLabel -> GlobalReg -> CmmExpr -> CmmAGraph
+mkUnwind lbl r e = mkMiddle $ CmmUnwind lbl r e
+
 ---------- Control transfer
 mkJump          :: DynFlags -> Convention -> CmmExpr
                 -> [CmmActual]
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index cbbf3b6..f3311bb 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -12,6 +12,7 @@ module StgCmmForeign (
   cgForeignCall,
   emitPrimCall, emitCCall,
   emitForeignCall,     -- For CmmParse
+  InitialSp,
   emitSaveThreadState,
   saveThreadState,
   emitLoadThreadState,
@@ -30,6 +31,7 @@ import StgCmmUtils
 import StgCmmClosure
 import StgCmmLayout
 
+import BlockId (newBlockId)
 import Cmm
 import CmmUtils
 import MkGraph
@@ -275,19 +277,34 @@ maybe_assign_temp e = do
 emitSaveThreadState :: FCode ()
 emitSaveThreadState = do
   dflags <- getDynFlags
-  code <- saveThreadState dflags
+  code <- saveThreadState dflags Nothing
   emit code
 
+-- | Given a @initial :: InitialSp@, @initial (CmmReg sp)@ is an expression
+-- of the current.
+type InitialSp = CmmExpr -> CmmExpr
+
 -- | Produce code to save the current thread state to @CurrentTSO@
-saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph
-saveThreadState dflags = do
+saveThreadState :: MonadUnique m => DynFlags -> Maybe InitialSp -> m CmmAGraph
+saveThreadState dflags initialSp = do
   tso <- newTemp (gcWord dflags)
   close_nursery <- closeNursery dflags tso
+  lbl <- newBlockId
+
   pure $ catAGraphs [
     -- tso = CurrentTSO;
     mkAssign (CmmLocal tso) stgCurrentTSO,
     -- tso->stackobj->sp = Sp;
     mkStore (cmmOffset dflags (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp,
+    -- unwind Sp = initialSp(tso->stackobj->sp)
+    case initialSp of
+      Just initial | debugLevel dflags > 0 ->
+        let tsoValue =
+              CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags))
+                      (bWord dflags)
+            spValue = cmmOffset dflags tsoValue (stack_SP dflags)
+        in mkUnwind (NewLabel lbl) Sp (initial $ CmmLoad spValue (bWord dflags))
+      _ -> mkNop,
     close_nursery,
     -- and save the current cost centre stack in the TSO when profiling:
     if gopt Opt_SccProfilingOn dflags then
@@ -351,15 +368,16 @@ closeNursery df tso = do
 emitLoadThreadState :: FCode ()
 emitLoadThreadState = do
   dflags <- getDynFlags
-  code <- loadThreadState dflags
+  code <- loadThreadState dflags Nothing
   emit code
 
 -- | Produce code to load the current thread state from @CurrentTSO@
-loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph
-loadThreadState dflags = do
+loadThreadState :: MonadUnique m => DynFlags -> Maybe (CmmExpr -> CmmExpr) -> m CmmAGraph
+loadThreadState dflags initialSp = do
   tso <- newTemp (gcWord dflags)
   stack <- newTemp (gcWord dflags)
   open_nursery <- openNursery dflags tso
+  lbl <- newBlockId
   pure $ catAGraphs [
     -- tso = CurrentTSO;
     mkAssign (CmmLocal tso) stgCurrentTSO,
@@ -367,6 +385,11 @@ loadThreadState dflags = do
     mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),
     -- Sp = stack->sp;
     mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),
+    -- unwind Sp = initialSp(Sp);
+    case initialSp of
+      Just initial | debugLevel dflags > 0 ->
+        mkUnwind (NewLabel lbl) Sp (initial (CmmReg sp))
+      _ -> mkNop,
     -- SpLim = stack->stack + RESERVED_STACK_WORDS;
     mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
                                 (rESERVED_STACK_WORDS dflags)),