projects
/
matthijs
/
master-project
/
cλash.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Use the CoreContext predicate functions.
[matthijs/master-project/cλash.git]
/
clash
/
CLasH
/
Normalize.hs
diff --git
a/clash/CLasH/Normalize.hs
b/clash/CLasH/Normalize.hs
index 4ce4ffa53b4b189b4f7983968f5aac0a18c47ad8..4fcc59a7470ac2a9f30b25d9d364be3ec83a5a8a 100644
(file)
--- a/
clash/CLasH/Normalize.hs
+++ b/
clash/CLasH/Normalize.hs
@@
-158,7
+158,7
@@
castsimpl c expr = return expr
-- By not inlining any other reference, we also prevent looping problems
-- with funextract and inlinedict.
inlinetoplevel :: Transform
-- By not inlining any other reference, we also prevent looping problems
-- with funextract and inlinedict.
inlinetoplevel :: Transform
-inlinetoplevel
(LetBinding:_) expr |
not (is_fun expr) =
+inlinetoplevel
c expr | not (null c) && is_letbinding_ctx (head c) &&
not (is_fun expr) =
case collectArgs expr of
(Var f, args) -> do
body_maybe <- needsInline f
case collectArgs expr of
(Var f, args) -> do
body_maybe <- needsInline f
@@
-216,12
+216,12
@@
needsInline f = do
-- body consisting of a bunch of nested lambdas containing a
-- non-function value (e.g., a complete application).
eta :: Transform
-- body consisting of a bunch of nested lambdas containing a
-- non-function value (e.g., a complete application).
eta :: Transform
-eta
(AppFirst:_) expr
= return expr
+eta
c expr | not (null c) && is_appfirst_ctx (head c)
= return expr
-- Also don't apply to arguments, since this can cause loops with
-- funextract. This isn't the proper solution, but due to an
-- implementation bug in notappargs, this is how it used to work so far.
-- Also don't apply to arguments, since this can cause loops with
-- funextract. This isn't the proper solution, but due to an
-- implementation bug in notappargs, this is how it used to work so far.
-
eta (AppSecond:_) expr
= return expr
-
eta c expr
| is_fun expr && not (is_lam expr) = do
+
| not (null c) && is_appsecond_ctx (head c)
= return expr
+
| is_fun expr && not (is_lam expr) = do
let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr
id <- Trans.lift $ mkInternalVar "param" arg_ty
change (Lam id (App expr (Var id)))
let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr
id <- Trans.lift $ mkInternalVar "param" arg_ty
change (Lam id (App expr (Var id)))
@@
-296,7
+296,7
@@
letflat c expr = return expr
-- Extract the return value from the body of the top level lambdas (of
-- which ther could be zero), unless it is a let expression (in which
-- case the next clause applies).
-- Extract the return value from the body of the top level lambdas (of
-- which ther could be zero), unless it is a let expression (in which
-- case the next clause applies).
-retvalsimpl c expr | all
(== LambdaBody)
c && not (is_lam expr) && not (is_let expr) = do
+retvalsimpl c expr | all
is_lambdabody_ctx
c && not (is_lam expr) && not (is_let expr) = do
local_var <- Trans.lift $ is_local_var expr
repr <- isRepr expr
if not local_var && repr
local_var <- Trans.lift $ is_local_var expr
repr <- isRepr expr
if not local_var && repr
@@
-308,7
+308,7
@@
retvalsimpl c expr | all (== LambdaBody) c && not (is_lam expr) && not (is_let e
-- Extract the return value from the body of a let expression, which is
-- itself the body of the top level lambdas (of which there could be
-- zero).
-- Extract the return value from the body of a let expression, which is
-- itself the body of the top level lambdas (of which there could be
-- zero).
-retvalsimpl c expr@(Let (Rec binds) body) | all
(== LambdaBody)
c = do
+retvalsimpl c expr@(Let (Rec binds) body) | all
is_lambdabody_ctx
c = do
-- Don't extract values that are already a local variable, to prevent
-- loops with ourselves.
local_var <- Trans.lift $ is_local_var body
-- Don't extract values that are already a local variable, to prevent
-- loops with ourselves.
local_var <- Trans.lift $ is_local_var body
@@
-410,15
+410,14
@@
funextract c expr = return expr
-- Make sure the scrutinee of a case expression is a local variable
-- reference.
scrutsimpl :: Transform
-- Make sure the scrutinee of a case expression is a local variable
-- reference.
scrutsimpl :: Transform
--- Don't touch scrutinees that are already simple
-scrutsimpl c expr@(Case (Var _) _ _ _) = return expr
--- Replace all other cases with a let that binds the scrutinee and a new
+-- Replace a case expression with a let that binds the scrutinee and a new
-- simple scrutinee, but only when the scrutinee is representable (to prevent
-- loops with inlinenonrep, though I don't think a non-representable scrutinee
-- simple scrutinee, but only when the scrutinee is representable (to prevent
-- loops with inlinenonrep, though I don't think a non-representable scrutinee
--- will be supported anyway...)
+-- will be supported anyway...)
and is not a local variable already.
scrutsimpl c expr@(Case scrut b ty alts) = do
repr <- isRepr scrut
scrutsimpl c expr@(Case scrut b ty alts) = do
repr <- isRepr scrut
- if repr
+ local_var <- Trans.lift $ is_local_var scrut
+ if repr && not local_var
then do
id <- Trans.lift $ mkBinderFor scrut "scrut"
change $ Let (NonRec id scrut) (Case (Var id) b ty alts)
then do
id <- Trans.lift $ mkBinderFor scrut "scrut"
change $ Let (NonRec id scrut) (Case (Var id) b ty alts)
@@
-490,7
+489,9
@@
casesimpl c expr@(Case scrut bndr ty alts) | not bndr_used = do
-- Wilden the binders of one alt, producing a list of bindings as a
-- sideeffect.
doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt)
-- Wilden the binders of one alt, producing a list of bindings as a
-- sideeffect.
doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt)
- doalt (con, bndrs, expr) = do
+ doalt (LitAlt _, _, _) = error $ "Don't know how to handle LitAlt in case expression: " ++ pprString expr
+ doalt alt@(DEFAULT, [], expr) = return ([], alt)
+ doalt (DataAlt dc, bndrs, expr) = do
-- Make each binder wild, if possible
bndrs_res <- Monad.zipWithM dobndr bndrs [0..]
let (newbndrs, bindings_maybe) = unzip bndrs_res
-- Make each binder wild, if possible
bndrs_res <- Monad.zipWithM dobndr bndrs [0..]
let (newbndrs, bindings_maybe) = unzip bndrs_res
@@
-500,7
+501,7
@@
casesimpl c expr@(Case scrut bndr ty alts) | not bndr_used = do
let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) expr
(exprbinding_maybe, expr') <- doexpr expr uses_bndrs
-- Create a new alternative
let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) expr
(exprbinding_maybe, expr') <- doexpr expr uses_bndrs
-- Create a new alternative
- let newalt = (
con
, newbndrs, expr')
+ let newalt = (
DataAlt dc
, newbndrs, expr')
let bindings = Maybe.catMaybes (bindings_maybe ++ [exprbinding_maybe])
return (bindings, newalt)
where
let bindings = Maybe.catMaybes (bindings_maybe ++ [exprbinding_maybe])
return (bindings, newalt)
where
@@
-522,7
+523,8
@@
casesimpl c expr@(Case scrut bndr ty alts) | not bndr_used = do
-- inlinenonrep).
if (not wild) && repr
then do
-- inlinenonrep).
if (not wild) && repr
then do
- caseexpr <- Trans.lift $ mkSelCase scrut i
+ let dc_i = datacon_index (CoreUtils.exprType scrut) dc
+ caseexpr <- Trans.lift $ mkSelCase scrut dc_i i
-- Create a new binder that will actually capture a value in this
-- case statement, and return it.
return (wildbndrs!!i, Just (b, caseexpr))
-- Create a new binder that will actually capture a value in this
-- case statement, and return it.
return (wildbndrs!!i, Just (b, caseexpr))
@@
-753,7
+755,7
@@
inlinenonrepresult :: Transform
-- that is fully applied (i.e., dos not have a function type) but is not
-- representable. We apply in any context, since non-representable
-- expressions are generally left alone and can occur anywhere.
-- that is fully applied (i.e., dos not have a function type) but is not
-- representable. We apply in any context, since non-representable
-- expressions are generally left alone and can occur anywhere.
-inlinenonrepresult context expr | not (is_
fun
expr) =
+inlinenonrepresult context expr | not (is_
applicable expr) && not (has_free_tyvars
expr) =
case collectArgs expr of
(Var f, args) | not (Id.isDictId f) -> do
repr <- isRepr expr
case collectArgs expr of
(Var f, args) | not (Id.isDictId f) -> do
repr <- isRepr expr
@@
-794,7
+796,7
@@
inlinenonrepresult context expr | not (is_fun expr) =
res_bndr <- Trans.lift $ mkBinderFor newapp "res"
-- Create extractor case expressions to extract each of the
-- free variables from the tuple.
res_bndr <- Trans.lift $ mkBinderFor newapp "res"
-- Create extractor case expressions to extract each of the
-- free variables from the tuple.
- sel_cases <- Trans.lift $ mapM (mkSelCase (Var res_bndr)) [0..n_free_vars-1]
+ sel_cases <- Trans.lift $ mapM (mkSelCase (Var res_bndr)
0
) [0..n_free_vars-1]
-- Bind the res_bndr to the result of the new application
-- and each of the free variables to the corresponding
-- Bind the res_bndr to the result of the new application
-- and each of the free variables to the corresponding
@@
-821,6
+823,10
@@
inlinenonrepresult context expr | not (is_fun expr) =
-- Leave all other expressions unchanged
inlinenonrepresult c expr = return expr
-- Leave all other expressions unchanged
inlinenonrepresult c expr = return expr
+----------------------------------------------------------------
+-- Type-class transformations
+----------------------------------------------------------------
+
--------------------------------
-- ClassOp resolution
--------------------------------
--------------------------------
-- ClassOp resolution
--------------------------------
@@
-952,7
+958,7
@@
letmerge c expr = return expr
-- What transforms to run?
transforms = [ ("inlinedict", inlinedict)
, ("inlinetoplevel", inlinetoplevel)
-- What transforms to run?
transforms = [ ("inlinedict", inlinedict)
, ("inlinetoplevel", inlinetoplevel)
-
--
, ("inlinenonrepresult", inlinenonrepresult)
+ , ("inlinenonrepresult", inlinenonrepresult)
, ("knowncase", knowncase)
, ("classopresolution", classopresolution)
, ("argprop", argprop)
, ("knowncase", knowncase)
, ("classopresolution", classopresolution)
, ("argprop", argprop)