ee36dcb96eeec698e8d0e5e1406dd8ba43a00c0f
[ghc.git] / compiler / simplStg / Unshare.lhs
1 \begin{code}
2 module Unshare (unshare) where
3
4 #include "HsVersions.h"
5
6 import StgSyn
7 import Id
8 import Outputable
9 import DynFlags         ( DynFlags(..))
10 import Data.List
11
12 unshare :: DynFlags -> [StgBinding] -> [StgBinding]
13 unshare dflags binds = map (unshareBinding dflags) binds
14
15 unshareBinding :: DynFlags -> StgBinding -> StgBinding
16 unshareBinding dflags bind = case bind of
17   StgNonRec x rhs -> StgNonRec x (unshareRhs dflags rhs)
18   StgRec xrhss    -> StgRec $ map (\(x, rhs) -> (x, unshareRhs dflags rhs)) xrhss
19
20 unshareRhs :: DynFlags -> StgRhs -> StgRhs
21 unshareRhs dflags rhs = case rhs of
22   StgRhsClosure ccs b_info fvs update_flag srt args expr
23     -> StgRhsClosure ccs b_info fvs flag' srt args (unshareExpr dflags expr)
24     where
25     flag' = case calledFun expr of
26         Just name -> if "myenum" `isSuffixOf` showPpr dflags name
27                 then 
28                         --pprTrace "XXX info: " (ppr (unfoldingInfo (Var.idInfo name))) $
29                         case update_flag of Updatable -> ReEntrant ; _ -> update_flag
30                 else update_flag
31         _ -> update_flag
32   StgRhsCon ccs con args
33     -> StgRhsCon ccs con args
34
35 calledFun :: StgExpr -> Maybe Id
36 calledFun expr = case expr of
37   StgApp f _args -> Just f
38   StgLit _l -> Nothing
39   StgConApp _dc _args -> Nothing
40   StgOpApp _op _args _ty -> Nothing
41   StgLam _xs e -> calledFun e
42   StgCase _e _case_lives _alts_lives _bndr _srt _alt_ty [(_, _, _, e')] -> calledFun e'
43   StgCase _e _case_lives _alts_lives _bndr _srt _alt_ty _alts -> Nothing
44   StgLet _bind e -> calledFun e
45   StgLetNoEscape _live_in_let _live_in_bind _bind e
46     -> calledFun e
47   StgSCC _cc _bump_entry _push_cc e -> calledFun e
48   StgTick _mod _tick_n e -> calledFun e
49
50 unshareExpr :: DynFlags -> StgExpr -> StgExpr
51 unshareExpr dflags e = case e of
52   -- Particularly important where (##) is concerned (Note [The nullary (# #) constructor])
53   StgApp f args ->
54         --pprTrace "name: " (ppr (Var.varName f)) $
55         StgApp f args
56   StgLit l -> StgLit l
57   StgConApp dc args -> StgConApp dc args
58   StgOpApp op args ty -> StgOpApp op args ty
59   StgLam xs e -> StgLam xs (unshareExpr dflags  e)
60   StgCase e case_lives alts_lives bndr srt alt_ty alts
61     -> StgCase (unshareExpr dflags e) case_lives alts_lives bndr srt alt_ty $
62         map (\(con, bndrs, uses, e) -> (con, bndrs, uses, unshareExpr dflags e)) alts
63   StgLet bind e -> StgLet (unshareBinding dflags bind) (unshareExpr dflags e)
64   StgLetNoEscape live_in_let live_in_bind bind e
65     -> StgLetNoEscape live_in_let live_in_bind (unshareBinding dflags bind) (unshareExpr dflags e)
66   StgSCC cc bump_entry push_cc e -> StgSCC cc bump_entry push_cc (unshareExpr dflags e)
67   StgTick mod tick_n e -> StgTick mod tick_n (unshareExpr dflags e)
68 \end{code}