projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Make the arity warning a bit more informative (DEBUG only)
[ghc-hetmet.git]
/
compiler
/
coreSyn
/
CorePrep.lhs
diff --git
a/compiler/coreSyn/CorePrep.lhs
b/compiler/coreSyn/CorePrep.lhs
index
908c90c
..
36b6f5c
100644
(file)
--- a/
compiler/coreSyn/CorePrep.lhs
+++ b/
compiler/coreSyn/CorePrep.lhs
@@
-11,10
+11,11
@@
module CorePrep (
#include "HsVersions.h"
#include "HsVersions.h"
+import PrelNames ( lazyIdKey, hasKey )
import CoreUtils
import CoreArity
import CoreFVs
import CoreUtils
import CoreArity
import CoreFVs
-import CoreLint
+import CoreMonad ( endPass )
import CoreSyn
import Type
import Coercion
import CoreSyn
import Type
import Coercion
@@
-85,10
+86,11
@@
The goal of this pass is to prepare for code generation.
8. Inject bindings for the "implicit" Ids:
* Constructor wrappers
* Constructor workers
8. Inject bindings for the "implicit" Ids:
* Constructor wrappers
* Constructor workers
- * Record selectors
We want curried definitions for all of these in case they
aren't inlined by some caller.
We want curried definitions for all of these in case they
aren't inlined by some caller.
+9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.lhs
+
This is all done modulo type applications and abstractions, so that
when type erasure is done for conversion to STG, we don't end up with
any trivial or useless bindings.
This is all done modulo type applications and abstractions, so that
when type erasure is done for conversion to STG, we don't end up with
any trivial or useless bindings.
@@
-145,7
+147,7
@@
corePrepPgm dflags binds data_tycons = do
floats2 <- corePrepTopBinds implicit_binds
return (deFloatTop (floats1 `appendFloats` floats2))
floats2 <- corePrepTopBinds implicit_binds
return (deFloatTop (floats1 `appendFloats` floats2))
- endPass dflags "CorePrep" Opt_D_dump_prep binds_out
+ endPass dflags "CorePrep" Opt_D_dump_prep binds_out []
return binds_out
corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
return binds_out
corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
@@
-341,9
+343,14
@@
cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr)
cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr)
-cpeRhsE env expr@(App {}) = cpeApp env expr
cpeRhsE env expr@(Var {}) = cpeApp env expr
cpeRhsE env expr@(Var {}) = cpeApp env expr
+cpeRhsE env (Var f `App` _ `App` arg)
+ | f `hasKey` lazyIdKey -- Replace (lazy a) by a
+ = cpeRhsE env arg -- See Note [lazyId magic] in MkId
+
+cpeRhsE env expr@(App {}) = cpeApp env expr
+
cpeRhsE env (Let bind expr)
= do { (env', new_binds) <- cpeBind NotTopLevel env bind
; (floats, body) <- cpeRhsE env' expr
cpeRhsE env (Let bind expr)
= do { (env', new_binds) <- cpeBind NotTopLevel env bind
; (floats, body) <- cpeRhsE env' expr
@@
-407,7
+414,7
@@
rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs
--------
rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
--------
rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
--- Remove top level lambdas by let-bindinig
+-- Remove top level lambdas by let-binding
rhsToBody (Note n expr)
-- You can get things like
rhsToBody (Note n expr)
-- You can get things like
@@
-475,7
+482,7
@@
cpeApp env expr
collect_args (App fun arg) depth
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
collect_args (App fun arg) depth
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
- ; let
+ ; let
(ss1, ss_rest) = case ss of
(ss1:ss_rest) -> (ss1, ss_rest)
[] -> (lazyDmd, [])
(ss1, ss_rest) = case ss of
(ss1:ss_rest) -> (ss1, ss_rest)
[] -> (lazyDmd, [])
@@
-511,10
+518,10
@@
cpeApp env expr
= collect_args fun depth -- They aren't used by the code generator
-- N-variable fun, better let-bind it
= collect_args fun depth -- They aren't used by the code generator
-- N-variable fun, better let-bind it
- -- ToDo: perhaps we can case-bind rather than let-bind this closure,
- -- since it is sure to be evaluated.
collect_args fun depth
= do { (fun_floats, fun') <- cpeArg env True fun ty
collect_args fun depth
= do { (fun_floats, fun') <- cpeArg env True fun ty
+ -- The True says that it's sure to be evaluated,
+ -- so we'll end up case-binding it
; return (fun', (fun', depth), ty, fun_floats, []) }
where
ty = exprType fun
; return (fun', (fun', depth), ty, fun_floats, []) }
where
ty = exprType fun
@@
-633,7
+640,6
@@
ignoreNote :: Note -> Bool
-- want to get this:
-- unzip = /\ab \xs. (__inline_me__ ...) a b xs
ignoreNote (CoreNote _) = True
-- want to get this:
-- unzip = /\ab \xs. (__inline_me__ ...) a b xs
ignoreNote (CoreNote _) = True
-ignoreNote InlineMe = True
ignoreNote _other = False
ignoreNote _other = False