X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=146f8cfd736236df6c3299bd199c0984fb6753a8;hb=27218ba74f28c527e0b3e88195169b6949d98899;hp=b0de6f294dd59b81a69b40d5aef38b94987f82f5;hpb=ab22f4e6456820c1b5169d75f5975a94e61f54ce;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index b0de6f2..146f8cf 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -620,6 +620,10 @@ exprIsHNF (Lit l) = True exprIsHNF (Type ty) = True -- Types are honorary Values; -- we don't mind copying them exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e +exprIsHNF (Note (TickBox {}) _) + = False +exprIsHNF (Note (BinaryTickBox {}) _) + = False exprIsHNF (Note _ e) = exprIsHNF e exprIsHNF (Cast e co) = exprIsHNF e exprIsHNF (App e (Type _)) = exprIsHNF e @@ -800,6 +804,14 @@ exprIsConApp_maybe (Cast expr co) Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args) }} +-- We do not want to tell the world that we have a +-- Cons, to *stop* Case of Known Cons, which removes +-- the TickBox. +exprIsConApp_maybe (Note (TickBox {}) expr) + = Nothing +exprIsConApp_maybe (Note (BinaryTickBox {}) expr) + = Nothing + exprIsConApp_maybe (Note _ expr) = exprIsConApp_maybe expr -- We ignore InlineMe notes in case we have @@ -1120,7 +1132,8 @@ eta_expand n us expr ty Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty')) where - lam_tv = mkTyVar (mkSysTvName uniq FSLIT("etaT")) (tyVarKind tv) + lam_tv = setVarName tv (mkSysTvName uniq FSLIT("etaT")) + -- Using tv as a base retains its tyvar/covar-ness (uniq:us2) = us ; Nothing -> @@ -1183,6 +1196,9 @@ exprArity e = go e go (Var v) = idArity v go (Lam x e) | isId x = go e + 1 | otherwise = go e + go (Note (TickBox {}) _) = 0 + go (Note (BinaryTickBox {}) _) + = 0 go (Note n e) = go e go (Cast e _) = go e go (App e (Type t)) = go e @@ -1300,6 +1316,8 @@ exprSize (Type t) = seqType t `seq` 1 noteSize (SCC cc) = cc `seq` 1 noteSize InlineMe = 1 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations +noteSize (TickBox m n) = m `seq` n `seq` 1 +noteSize (BinaryTickBox m t e) = m `seq` t `seq` e `seq` 1 varSize :: Var -> Int varSize b | isTyVar b = 1 @@ -1445,6 +1463,8 @@ rhsIsStatic this_pkg rhs = is_static False rhs is_static False (Lam b e) = isRuntimeVar b || is_static False e is_static in_arg (Note (SCC _) e) = False + is_static in_arg (Note (TickBox {}) e) = False + is_static in_arg (Note (BinaryTickBox {}) e) = False is_static in_arg (Note _ e) = is_static in_arg e is_static in_arg (Cast e co) = is_static in_arg e