Skip to content

Commit

Permalink
Account for 'appProp' in 'reduceNonRepPrim'. Fix #974
Browse files Browse the repository at this point in the history
  • Loading branch information
@martijnbastiaan @christiaanb
martijnbastiaan authored and christiaanb committed Jan 15, 2020
1 parent 829ee4a commit 3dcf78b
Show file tree
Hide file tree
Showing 4 changed files with 75 additions and 17 deletions.
1 change: 1 addition & 0 deletions CHANGELOG.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@

## 1.0.2
* Fixes issues:
* [#974](https://github.com/clash-lang/clash-compiler/issues/974): Fix indirect shadowing in `reduceNonRepPrim`
* [#895](https://github.com/clash-lang/clash-compiler/issues/895): VHDL type error when generating `Maybe (Vec 2 (Signed 8), Index 1)`
* [#869](https://github.com/clash-lang/clash-compiler/issues/869): PLL is duplicated in Blinker.hs example

Expand Down
1 change: 1 addition & 0 deletions clash-lib/clash-lib.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -126,6 +126,7 @@ Library
containers >= 0.5.0.0 && < 0.7,
data-binary-ieee754 >= 0.4.4 && < 0.6,
deepseq >= 1.3.0.2 && < 1.5,
dlist >= 0.8 && < 0.9,
directory >= 1.2.0.1 && < 1.4,
errors >= 1.4.2 && < 2.4,
exceptions >= 0.8.3 && < 0.11.0,
Expand Down
50 changes: 48 additions & 2 deletions clash-lib/src/Clash/Core/Term.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}

Expand All @@ -24,16 +25,18 @@ module Clash.Core.Term
, TickInfo (..), NameMod (..)
, PrimInfo (..)
, WorkInfo (..)
, CoreContext (..), Context, isLambdaBodyCtx, isTickCtx
, collectArgs, collectArgsTicks, collectTicks, primArg
, CoreContext (..), Context, isLambdaBodyCtx, isTickCtx, walkTerm
, collectArgs, collectArgsTicks, collectTicks, collectTermIds, primArg
, partitionTicks
)
where

-- External Modules
import Control.DeepSeq
import Data.Binary (Binary)
import qualified Data.DList as DList
import Data.Either (lefts, rights)
import Data.Maybe (catMaybes)
import Data.Hashable (Hashable)
import Data.List (partition)
import Data.Text (Text)
Expand Down Expand Up @@ -236,3 +239,46 @@ partitionTicks
-> ([TickInfo], [TickInfo])
-- ^ (source ticks, nameMod ticks)
partitionTicks = partition (\case {SrcSpan {} -> True; _ -> False})

-- | Visit all terms in a term, testing it with a predicate, and returning
-- a list of predicate yields.
walkTerm :: forall a . (Term -> Maybe a) -> Term -> [a]
walkTerm f = catMaybes . DList.toList . go
where
go :: Term -> DList.DList (Maybe a)
go t = DList.cons (f t) $ case t of
Var _ -> mempty
Data _ -> mempty
Literal _ -> mempty
Prim _ _ -> mempty
Lam _ t1 -> go t1
TyLam _ t1 -> go t1
App t1 t2 -> go t1 <> go t2
TyApp t1 _ -> pure (f t1)
Letrec bndrs t1 -> pure (f t1) <> mconcat (map (go . snd) bndrs)
Case t1 _ alts -> pure (f t1) <> mconcat (map (go . snd) alts)
Cast t1 _ _ -> go t1
Tick _ t1 -> pure (f t1)

-- Collect all term ids mentioned in a term
collectTermIds :: Term -> [Id]
collectTermIds = concat . walkTerm (Just . go)
where
go :: Term -> [Id]
go (Var i) = [i]
go (Lam i _) = [i]
go (Letrec bndrs _) = map fst bndrs
go (Case _ _ alts) = concatMap (pat . fst) alts
go (Data _) = []
go (Literal _) = []
go (Prim _ _) = []
go (TyLam _ _) = []
go (App _ _) = []
go (TyApp _ _) = []
go (Cast _ _ _) = []
go (Tick _ _) = []

pat :: Pat -> [Id]
pat (DataPat _ _ ids) = ids
pat (LitPat _) = []
pat DefaultPat = []
40 changes: 25 additions & 15 deletions clash-lib/src/Clash/Normalize/PrimitiveReductions.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -49,7 +49,8 @@ import Clash.Core.Literal (Literal (..))
import Clash.Core.Name (nameOcc)
import Clash.Core.Pretty (showPpr)
import Clash.Core.Term
(CoreContext (..), PrimInfo (..), Term (..), WorkInfo (..), Pat (..))
(CoreContext (..), PrimInfo (..), Term (..), WorkInfo (..), Pat (..),
collectTermIds)
import Clash.Core.Type (LitTy (..), Type (..),
TypeView (..), coreView1,
mkFunTy, mkTyConApp,
Expand Down Expand Up @@ -129,8 +130,9 @@ reduceZipWith (TransformContext is0 ctx) n lhsElTy rhsElTy resElTy fun lhsArg rh
= do
uniqs0 <- Lens.use uniqSupply
fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun
let (uniqs1,(varsL,elemsL)) = second (second concat . unzip)
$ extractElems uniqs0 is0 consCon lhsElTy 'L' n lhsArg
let is1 = extendInScopeSetList is0 (collectTermIds fun1)
(uniqs1,(varsL,elemsL)) = second (second concat . unzip)
$ extractElems uniqs0 is1 consCon lhsElTy 'L' n lhsArg
is2 = extendInScopeSetList is0 (map fst elemsL)
(uniqs2,(varsR,elemsR)) = second (second concat . unzip)
$ extractElems uniqs1 is2 consCon rhsElTy 'R' n rhsArg
Expand Down Expand Up @@ -165,8 +167,9 @@ reduceMap (TransformContext is0 ctx) n argElTy resElTy fun arg = do
= do
uniqs0 <- Lens.use uniqSupply
fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun
let (uniqs1,(vars,elems)) = second (second concat . unzip)
$ extractElems uniqs0 is0 consCon argElTy 'A' n arg
let is1 = extendInScopeSetList is0 (collectTermIds fun1)
(uniqs1,(vars,elems)) = second (second concat . unzip)
$ extractElems uniqs0 is1 consCon argElTy 'A' n arg
funApps = map (fun1 `App`) vars
lbody = mkVec nilCon consCon resElTy n funApps
lb = Letrec (init elems) lbody
Expand Down Expand Up @@ -198,7 +201,8 @@ reduceImap (TransformContext is0 ctx) n argElTy resElTy fun arg = do
= do
uniqs0 <- Lens.use uniqSupply
fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun
let (uniqs1,nTv) = mkUniqSystemTyVar (uniqs0,is0) ("n",typeNatKind)
let is1 = extendInScopeSetList is0 (collectTermIds fun1)
(uniqs1,nTv) = mkUniqSystemTyVar (uniqs0,is1) ("n",typeNatKind)
(uniqs2,(vars,elems)) = second (second concat . unzip)
$ uncurry extractElems uniqs1 consCon argElTy 'I' n arg
(Right idxTy:_,_) = splitFunForallTy (termType tcm fun)
Expand Down Expand Up @@ -248,11 +252,12 @@ reduceTraverse (TransformContext is0 ctx) n aTy fTy bTy dict fun arg = do
= do
uniqs0 <- Lens.use uniqSupply
fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun
let (Just apDictTc) = lookupUniqMap apDictTcNm tcm
let is1 = extendInScopeSetList is0 (collectTermIds fun1)
(Just apDictTc) = lookupUniqMap apDictTcNm tcm
[apDictCon] = tyConDataCons apDictTc
(Just apDictIdTys) = dataConInstArgTys apDictCon [fTy]
(uniqs1,apDictIds@[functorDictId,pureId,apId,_,_]) =
mapAccumR mkUniqInternalId (uniqs0,is0)
mapAccumR mkUniqInternalId (uniqs0,is1)
(zip ["functorDict","pure","ap","apConstL","apConstR"]
apDictIdTys)

Expand Down Expand Up @@ -381,8 +386,9 @@ reduceFoldr (TransformContext is0 ctx) n aTy fun start arg = do
= do
uniqs0 <- Lens.use uniqSupply
fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun
let (uniqs1,(vars,elems)) = second (second concat . unzip)
$ extractElems uniqs0 is0 consCon aTy 'G' n arg
let is1 = extendInScopeSetList is0 (collectTermIds fun1)
(uniqs1,(vars,elems)) = second (second concat . unzip)
$ extractElems uniqs0 is1 consCon aTy 'G' n arg
lbody = foldr (\l r -> mkApps fun1 [Left l,Left r]) start vars
lb = Letrec (init elems) lbody
uniqSupply Lens..= uniqs1
Expand Down Expand Up @@ -416,8 +422,9 @@ reduceFold (TransformContext is0 ctx) n aTy fun arg = do
= do
uniqs0 <- Lens.use uniqSupply
fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun
let (uniqs1,(vars,elems)) = second (second concat . unzip)
$ extractElems uniqs0 is0 consCon aTy 'F' n arg
let is1 = extendInScopeSetList is0 (collectTermIds fun1)
(uniqs1,(vars,elems)) = second (second concat . unzip)
$ extractElems uniqs0 is1 consCon aTy 'F' n arg
lbody = foldV fun1 vars
lb = Letrec (init elems) lbody
uniqSupply Lens..= uniqs1
Expand Down Expand Up @@ -447,7 +454,7 @@ reduceDFold
-- ^ The vector to fold
-> NormalizeSession Term
reduceDFold _ 0 _ _ start _ = changed start
reduceDFold inScope n aTy fun start arg = do
reduceDFold is0 n aTy fun start arg = do
tcm <- Lens.view tcCache
let ty = termType tcm arg
go tcm ty
Expand All @@ -459,8 +466,11 @@ reduceDFold inScope n aTy fun start arg = do
, [_,consCon] <- tyConDataCons vecTc
= do
uniqs0 <- Lens.use uniqSupply
let (uniqs1,(vars,elems)) = second (second concat . unzip)
$ extractElems uniqs0 inScope consCon aTy 'D' n arg
let is1 = extendInScopeSetList is0 (collectTermIds fun)
-- TODO: Should 'constantPropagation' be used on 'fun'? It seems to
-- TOOD: be used for every other function in this module.
(uniqs1,(vars,elems)) = second (second concat . unzip)
$ extractElems uniqs0 is1 consCon aTy 'D' n arg
(_ltv:Right snTy:_,_) = splitFunForallTy (termType tcm fun)
(TyConApp snatTcNm _) = tyView snTy
(Just snatTc) = lookupUniqMap snatTcNm tcm
Expand Down

0 comments on commit 3dcf78b

Please sign in to comment.