Add an unshare stg2stg phase
authorJoachim Breitner <mail@joachim-breitner.de>
Fri, 3 Aug 2012 13:27:19 +0000 (15:27 +0200)
committerJoachim Breitner <mail@joachim-breitner.de>
Mon, 27 Aug 2012 12:32:27 +0000 (14:32 +0200)
Just a stub for experimentation: This currently marks every think as
reentrant that calls a function whose name ends in myenum.

compiler/ghc.cabal.in
compiler/main/DynFlags.hs
compiler/simplStg/SimplStg.lhs
compiler/simplStg/Unshare.lhs [new file with mode: 0644]

index 12ed631..e5e252d 100644 (file)
@@ -368,6 +368,7 @@ Library
         SimplStg
         StgStats
         UnariseStg
+        Unshare
         Rules
         SpecConstr
         Specialise
index 8abe664..ff71582 100644 (file)
@@ -300,6 +300,7 @@ data DynFlag
    | Opt_NoHsMain
    | Opt_SplitObjs
    | Opt_StgStats
+   | Opt_StgUnshare
    | Opt_HideAllPackages
    | Opt_PrintBindResult
    | Opt_Haddock
@@ -1411,19 +1412,22 @@ data StgToDo
   -- There's also setStgVarInfo, but its absolute "lastness"
   -- is so critical that it is hardwired in (no flag).
   | D_stg_stats
+  | D_stg_unshare
 
 getStgToDo :: DynFlags -> [StgToDo]
 getStgToDo dflags
-  = todo2
+  = todo3
   where
         stg_stats = dopt Opt_StgStats dflags
+        stg_unshare = dopt Opt_StgUnshare dflags
 
-        todo1 = if stg_stats then [D_stg_stats] else []
+        todo1 = if stg_unshare then [D_stg_unshare] else []
+        todo2 = if stg_stats then D_stg_stats : todo1 else todo1
 
-        todo2 | WayProf `elem` wayNames dflags
-              = StgDoMassageForProfiling : todo1
+        todo3 | WayProf `elem` wayNames dflags
+              = StgDoMassageForProfiling : todo2
               | otherwise
-              = todo1
+              = todo2
 
 {- **********************************************************************
 %*                                                                      *
@@ -1707,6 +1711,7 @@ dynamic_flags = [
 
         ------ Debugging ----------------------------------------------------
   , Flag "dstg-stats"     (NoArg (setDynFlag Opt_StgStats))
+  , Flag "dstg-unshare"     (NoArg (setDynFlag Opt_StgUnshare))
 
   , Flag "ddump-cmm"               (setDumpFlag Opt_D_dump_cmm)
   , Flag "ddump-raw-cmm"           (setDumpFlag Opt_D_dump_raw_cmm)
index 635df3c..0bc413f 100644 (file)
@@ -22,6 +22,7 @@ import SCCfinal               ( stgMassageForProfiling )
 import StgLint         ( lintStgBindings )
 import StgStats                ( showStgStats )
 import UnariseStg       ( unarise )
+import Unshare          ( unshare )
 import SRT             ( computeSRTs )
 
 import DynFlags                ( DynFlags(..), DynFlag(..), dopt, StgToDo(..),
@@ -81,6 +82,10 @@ stg2stg dflags module_name binds
             trace (showStgStats binds)
             end_pass us2 "StgStats" ccs binds
 
+         D_stg_unshare ->
+            trace (showStgStats binds)
+            end_pass us2 "StgUnshare" ccs (unshare dflags binds)
+
          StgDoMassageForProfiling ->
             {-# SCC "ProfMassage" #-}
             let
diff --git a/compiler/simplStg/Unshare.lhs b/compiler/simplStg/Unshare.lhs
new file mode 100644 (file)
index 0000000..53d06a0
--- /dev/null
@@ -0,0 +1,68 @@
+\begin{code}
+module Unshare (unshare) where
+
+#include "HsVersions.h"
+
+import StgSyn
+import Id
+import Outputable
+import DynFlags         ( DynFlags(..))
+import Data.List
+
+unshare :: DynFlags -> [StgBinding] -> [StgBinding]
+unshare dflags binds = map (unshareBinding dflags) binds
+
+unshareBinding :: DynFlags -> StgBinding -> StgBinding
+unshareBinding dflags bind = case bind of
+  StgNonRec x rhs -> StgNonRec x (unshareRhs dflags rhs)
+  StgRec xrhss    -> StgRec $ map (\(x, rhs) -> (x, unshareRhs dflags rhs)) xrhss
+
+unshareRhs :: DynFlags -> StgRhs -> StgRhs
+unshareRhs dflags rhs = case rhs of
+  StgRhsClosure ccs b_info fvs update_flag srt args expr
+    -> StgRhsClosure ccs b_info fvs flag' srt args (unshareExpr dflags expr)
+    where
+    flag' = case calledFun expr of
+        Just name -> if "myenum" `isSuffixOf` showPpr dflags name
+                then 
+                        --pprTrace "XXX info: " (ppr (unfoldingInfo (Var.idInfo name))) $
+                        case update_flag of Updatable -> ReEntrant ; _ -> update_flag
+                else update_flag
+        _ -> update_flag
+  StgRhsCon ccs con args
+    -> StgRhsCon ccs con args
+
+calledFun :: StgExpr -> Maybe Id
+calledFun e = case e of
+  StgApp f _args -> Just f
+  StgLit _l -> Nothing
+  StgConApp _dc _args -> Nothing
+  StgOpApp _op _args _ty -> Nothing
+  StgLam _xs e -> calledFun e
+  StgCase _e _case_lives _alts_lives _bndr _srt _alt_ty [(_, _, _, e')] -> calledFun e'
+  StgCase _e _case_lives _alts_lives _bndr _srt _alt_ty _alts -> Nothing
+  StgLet _bind _e -> calledFun e
+  StgLetNoEscape _live_in_let _live_in_bind _bind e
+    -> calledFun e
+  StgSCC _cc _bump_entry _push_cc e -> calledFun e
+  StgTick _mod _tick_n e -> calledFun e
+
+unshareExpr :: DynFlags -> StgExpr -> StgExpr
+unshareExpr dflags e = case e of
+  -- Particularly important where (##) is concerned (Note [The nullary (# #) constructor])
+  StgApp f args ->
+        --pprTrace "name: " (ppr (Var.varName f)) $
+        StgApp f args
+  StgLit l -> StgLit l
+  StgConApp dc args -> StgConApp dc args
+  StgOpApp op args ty -> StgOpApp op args ty
+  StgLam xs e -> StgLam xs (unshareExpr dflags  e)
+  StgCase e case_lives alts_lives bndr srt alt_ty alts
+    -> StgCase (unshareExpr dflags e) case_lives alts_lives bndr srt alt_ty $
+        map (\(con, bndrs, uses, e) -> (con, bndrs, uses, unshareExpr dflags e)) alts
+  StgLet bind e -> StgLet (unshareBinding dflags bind) (unshareExpr dflags e)
+  StgLetNoEscape live_in_let live_in_bind bind e
+    -> StgLetNoEscape live_in_let live_in_bind (unshareBinding dflags bind) (unshareExpr dflags e)
+  StgSCC cc bump_entry push_cc e -> StgSCC cc bump_entry push_cc (unshareExpr dflags e)
+  StgTick mod tick_n e -> StgTick mod tick_n (unshareExpr dflags e)
+\end{code}