diff options
| author | Gabor Greif <ggreif@gmail.com> | 2017-07-30 11:22:28 (GMT) |
|---|---|---|
| committer | Gabor Greif <ggreif@gmail.com> | 2017-07-30 13:48:34 (GMT) |
| commit | 16589a6ee13cc9816f7d6b78880af3bbae10e6f2 (patch) | |
| tree | 5ee9db4e10308d37d21814b7fba99cad9268da08 | |
| parent | fd301b69096415f7bb01f95c2ea2d22f12d4991c (diff) | |
| download | ghc-16589a6ee13cc9816f7d6b78880af3bbae10e6f2.zip ghc-16589a6ee13cc9816f7d6b78880af3bbae10e6f2.tar.gz ghc-16589a6ee13cc9816f7d6b78880af3bbae10e6f2.tar.bz2 | |
WIP: debugging
| -rw-r--r-- | compiler/simplStg/StgCse.hs | 10 |
1 files changed, 8 insertions, 2 deletions
diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs index ee89137..c4dabb3 100644 --- a/compiler/simplStg/StgCse.hs +++ b/compiler/simplStg/StgCse.hs @@ -113,7 +113,7 @@ newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) } newtype LaxDataCon = Lax DataCon instance NamedThing LaxDataCon where - getName (Lax dc) | isVanillaDataCon dc && not hasStrict && not unpacked = mkFCallName uniq "" -- FIXME: is there a better way? + getName (Lax dc) | False && isVanillaDataCon dc && not hasStrict && not unpacked = mkFCallName uniq "" -- FIXME: is there a better way? where uniq = mkUniqueGrimily . negate $ dataConTag dc * 1048576 + length (dataConOrigArgTys dc) -- FIXME hasStrict = any (\case HsLazy -> False; _ -> True) (dataConImplBangs dc) unpacked = isUnboxedTupleCon dc || isUnboxedSumCon dc @@ -123,12 +123,16 @@ instance NamedThing LaxDataCon where instance TrieMap ConAppMap where type Key ConAppMap = (LaxDataCon, [StgArg]) emptyTM = CAM emptyTM + lookupTM (dataCon, args) | traceLookup dataCon = undefined lookupTM (dataCon, args) = un_cam >.> lkDNamed dataCon >=> lookupTM args alterTM (dataCon, args) f m = m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f } foldTM k = un_cam >.> foldTM (foldTM k) mapTM f = un_cam >.> mapTM (mapTM f) >.> CAM +traceLookup (Lax dc) = pprTrace "lookupTM" (ppr dc) False +{-# NOINLINE traceLookup #-} + ----------------- -- The CSE Env -- ----------------- @@ -197,7 +201,9 @@ envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env) addDataCon :: OutId -> LaxDataCon -> [OutStgArg] -> CseEnv -> CseEnv -- do not bother with nullary data constructors, they are static anyways -addDataCon _ _ [] env = env +addDataCon bndr dataCon [] env = env { ce_conAppMap = new_env } + where new_env = alterTM (dataCon, []) (\case Nothing -> pure bndr; p -> p) (ce_conAppMap env) +--addDataCon _ _ [] env = env addDataCon bndr dataCon args env = env { ce_conAppMap = new_env } where new_env = insertTM (dataCon, args) bndr (ce_conAppMap env) |