diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.6.9 +* Fixes bugs: + * `case undefined of ...` should reduce to `undefined` [#116](https://github.com/clash-lang/clash-compiler/issues/109) + * Type families obscure eligibility for synthesis [#114](https://github.com/clash-lang/clash-compiler/issues/114) + ## 0.6.8 *January 13th 2015* * New features: * Support for Haskell's: `Char`, `Int8`, `Int16`, `Int32`, `Int64`, `Word`, `Word8`, `Word16`, `Word32`, `Word64`. diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -1,5 +1,5 @@ Name: clash-lib -Version: 0.6.8 +Version: 0.6.9 Synopsis: CAES Language for Synchronous Hardware - As a Library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -49,7 +49,7 @@ License-file: LICENSE Author: Christiaan Baaij Maintainer: Christiaan Baaij -Copyright: Copyright © 2012-2015 University of Twente +Copyright: Copyright © 2012-2016 University of Twente Category: Hardware Build-type: Simple diff --git a/src/CLaSH/Backend.hs b/src/CLaSH/Backend.hs --- a/src/CLaSH/Backend.hs +++ b/src/CLaSH/Backend.hs @@ -1,3 +1,9 @@ +{-| + Copyright : (C) 2015-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + module CLaSH.Backend where import Data.HashSet (HashSet) @@ -44,3 +50,7 @@ expr :: Bool -> Expr -> State state Doc -- | Bit-width of Int/Word/Integer iwWidth :: State state Int + -- | Convert to a bit-vector + toBV :: HWType -> Text -> State state Doc + -- | Convert from a bit-vector + fromBV :: HWType -> Text -> State state Doc diff --git a/src/CLaSH/Core/DataCon.hs b/src/CLaSH/Core/DataCon.hs --- a/src/CLaSH/Core/DataCon.hs +++ b/src/CLaSH/Core/DataCon.hs @@ -1,3 +1,11 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Data Constructors in CoreHW +-} + {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -5,7 +13,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} --- | Data Constructors in CoreHW module CLaSH.Core.DataCon ( DataCon (..) , DcName diff --git a/src/CLaSH/Core/FreeVars.hs b/src/CLaSH/Core/FreeVars.hs --- a/src/CLaSH/Core/FreeVars.hs +++ b/src/CLaSH/Core/FreeVars.hs @@ -1,4 +1,11 @@ --- | Free variable calculations +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Free variable calculations +-} + module CLaSH.Core.FreeVars where import Control.Lens.Fold (Fold) diff --git a/src/CLaSH/Core/Literal.hs b/src/CLaSH/Core/Literal.hs --- a/src/CLaSH/Core/Literal.hs +++ b/src/CLaSH/Core/Literal.hs @@ -1,9 +1,16 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Term Literal +-} + {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} --- | Term Literal module CLaSH.Core.Literal ( Literal (..) , literalType diff --git a/src/CLaSH/Core/Pretty.hs b/src/CLaSH/Core/Pretty.hs --- a/src/CLaSH/Core/Pretty.hs +++ b/src/CLaSH/Core/Pretty.hs @@ -1,7 +1,15 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Pretty printing class and instances for CoreHW +-} + {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} --- | Pretty printing class and instances for CoreHW + module CLaSH.Core.Pretty ( Pretty (..) , showDoc diff --git a/src/CLaSH/Core/Subst.hs b/src/CLaSH/Core/Subst.hs --- a/src/CLaSH/Core/Subst.hs +++ b/src/CLaSH/Core/Subst.hs @@ -1,4 +1,11 @@ --- | Capture-free substitution function for CoreHW +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Capture-free substitution function for CoreHW +-} + module CLaSH.Core.Subst where import Unbound.Generics.LocallyNameless (subst, substs) diff --git a/src/CLaSH/Core/Term.hs b/src/CLaSH/Core/Term.hs --- a/src/CLaSH/Core/Term.hs +++ b/src/CLaSH/Core/Term.hs @@ -1,3 +1,11 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Term representation in the CoreHW language: System F + LetRec + Case +-} + {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} @@ -6,7 +14,6 @@ {-# OPTIONS_GHC -fno-specialise #-} --- | Term representation in the CoreHW language: System F + LetRec + Case module CLaSH.Core.Term ( Term (..) , TmName diff --git a/src/CLaSH/Core/Term.hs-boot b/src/CLaSH/Core/Term.hs-boot --- a/src/CLaSH/Core/Term.hs-boot +++ b/src/CLaSH/Core/Term.hs-boot @@ -1,3 +1,9 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + {-# OPTIONS_GHC -fno-warn-missing-methods #-} module CLaSH.Core.Term where diff --git a/src/CLaSH/Core/TyCon.hs b/src/CLaSH/Core/TyCon.hs --- a/src/CLaSH/Core/TyCon.hs +++ b/src/CLaSH/Core/TyCon.hs @@ -1,10 +1,17 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Type Constructors in CoreHW +-} + {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} --- | Type Constructors in CoreHW module CLaSH.Core.TyCon ( TyCon (..) , TyConName diff --git a/src/CLaSH/Core/TyCon.hs-boot b/src/CLaSH/Core/TyCon.hs-boot --- a/src/CLaSH/Core/TyCon.hs-boot +++ b/src/CLaSH/Core/TyCon.hs-boot @@ -1,3 +1,9 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + module CLaSH.Core.TyCon where import Unbound.Generics.LocallyNameless (Name) diff --git a/src/CLaSH/Core/Type.hs b/src/CLaSH/Core/Type.hs --- a/src/CLaSH/Core/Type.hs +++ b/src/CLaSH/Core/Type.hs @@ -1,3 +1,11 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Types in CoreHW +-} + {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} @@ -7,7 +15,6 @@ {-# OPTIONS_GHC -fno-specialise #-} --- | Types in CoreHW module CLaSH.Core.Type ( Type (..) , TypeView (..) @@ -28,6 +35,7 @@ , splitFunTy , splitFunTys , splitFunForallTy + , splitCoreFunForallTy , splitTyConAppM , isPolyFunTy , isPolyFunCoreTy @@ -36,6 +44,7 @@ , applyFunTy , applyTy , findFunSubst + , undefinedTy ) where @@ -48,10 +57,11 @@ import GHC.Generics (Generic(..)) import Unbound.Generics.LocallyNameless (Alpha(..),Bind,Fresh, Subst(..),SubstName(..), - acompare,aeq,bind, + acompare,aeq,bind,embed, gacompare,gaeq,gfvAny, runFreshM,unbind) -import Unbound.Generics.LocallyNameless.Name (Name,name2String) +import Unbound.Generics.LocallyNameless.Name (Name,name2String, + string2Name) import Unbound.Generics.LocallyNameless.Extra () import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) @@ -255,6 +265,18 @@ go args (tyView -> FunTy arg res) = go (Right arg:args) res go args ty = (reverse args,ty) +-- | Split a poly-function type in a: list of type-binders and argument types, +-- and the result type. Looks through 'Signal' and type functions. +splitCoreFunForallTy :: HashMap TyConName TyCon + -> Type + -> ([Either TyVar Type], Type) +splitCoreFunForallTy tcm = go [] + where + go args (ForAllTy b) = let (tv, ty) = runFreshM $ unbind b + in go (Left tv:args) ty + go args (coreView tcm -> FunTy arg res) = go (Right arg:args) res + go args ty = (reverse args, ty) + -- | Is a type a polymorphic or function type? isPolyFunTy :: Type -> Bool @@ -336,3 +358,9 @@ tySubts <- zipWithM funSubst argTys argTys' return (concat tySubts) funSubst _ _ = Nothing + +-- | The type of GHC.Err.undefined :: forall a . a +undefinedTy :: Type +undefinedTy = + let aNm = string2Name "a" + in ForAllTy (bind (TyVar aNm (embed liftedTypeKind)) (VarTy liftedTypeKind aNm)) diff --git a/src/CLaSH/Core/Type.hs-boot b/src/CLaSH/Core/Type.hs-boot --- a/src/CLaSH/Core/Type.hs-boot +++ b/src/CLaSH/Core/Type.hs-boot @@ -1,3 +1,9 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} diff --git a/src/CLaSH/Core/TysPrim.hs b/src/CLaSH/Core/TysPrim.hs --- a/src/CLaSH/Core/TysPrim.hs +++ b/src/CLaSH/Core/TysPrim.hs @@ -1,4 +1,11 @@ --- | Builtin Type and Kind definitions +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Builtin Type and Kind definitions +-} + module CLaSH.Core.TysPrim ( liftedTypeKind , typeNatKind diff --git a/src/CLaSH/Core/Util.hs b/src/CLaSH/Core/Util.hs --- a/src/CLaSH/Core/Util.hs +++ b/src/CLaSH/Core/Util.hs @@ -1,8 +1,15 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Smart constructor and destructor functions for CoreHW +-} + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} --- | Smart constructor and destructor functions for CoreHW module CLaSH.Core.Util where import Control.Monad.Trans.Except (Except, throwE) diff --git a/src/CLaSH/Core/Var.hs b/src/CLaSH/Core/Var.hs --- a/src/CLaSH/Core/Var.hs +++ b/src/CLaSH/Core/Var.hs @@ -1,8 +1,15 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Variables in CoreHW +-} + {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} --- | Variables in CoreHW module CLaSH.Core.Var ( Var (..) , Id diff --git a/src/CLaSH/Driver.hs b/src/CLaSH/Driver.hs --- a/src/CLaSH/Driver.hs +++ b/src/CLaSH/Driver.hs @@ -1,7 +1,14 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Module that connects all the parts of the CLaSH compiler library +-} + {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} --- | Module that connects all the parts of the CLaSH compiler library module CLaSH.Driver where import qualified Control.Concurrent.Supply as Supply @@ -9,9 +16,11 @@ import Control.Monad (when) import Control.Monad.State (evalState, get) import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HashSet import Data.IntMap (IntMap) import Data.Maybe (fromMaybe) +import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as Text import qualified Data.Time.Clock as Clock import qualified System.Directory as Directory @@ -29,16 +38,19 @@ import CLaSH.Driver.TopWrapper import CLaSH.Driver.Types import CLaSH.Netlist (genComponentName, genNetlist) +import CLaSH.Netlist.BlackBox.Parser (runParse) +import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate) import CLaSH.Netlist.Types (Component (..), HWType) import CLaSH.Normalize (checkNonRecursive, cleanupGraph, normalize, runNormalization) import CLaSH.Primitives.Types +import CLaSH.Util (first) -- | Create a set of target HDL files for a set of functions generateHDL :: forall backend . Backend backend => BindingMap -- ^ Set of functions -> Maybe backend - -> PrimMap -- ^ Primitive / BlackBox Definitions + -> PrimMap (Text.Text) -- ^ Primitive / BlackBox Definitions -> HashMap TyConName TyCon -- ^ TyCon cache -> IntMap TyConName -- ^ Tuple TyCon cache -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator @@ -52,6 +64,9 @@ start <- Clock.getCurrentTime prepTime <- start `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime let prepStartDiff = Clock.diffUTCTime prepTime start + + primMap' = (HM.map parsePrimitive :: PrimMap Text.Text -> PrimMap BlackBoxTemplate) primMap + putStrLn $ "Loading dependencies took " ++ show prepStartDiff (supplyN,supplyTB) <- Supply.splitSupply @@ -62,7 +77,7 @@ let doNorm = do norm <- normalize [topEntity] let normChecked = checkNonRecursive topEntity norm cleanupGraph topEntity normChecked - transformedBindings = runNormalization opts supplyN bindingsMap typeTrans tcm tupTcm eval doNorm + transformedBindings = runNormalization opts supplyN bindingsMap typeTrans tcm tupTcm eval primMap' doNorm normTime <- transformedBindings `deepseq` Clock.getCurrentTime let prepNormDiff = Clock.diffUTCTime normTime prepTime @@ -70,7 +85,7 @@ let modName = takeWhile (/= '.') (name2String topEntity) iw = opt_intWidth opts - (netlist,dfiles,cmpCnt) <- genNetlist Nothing transformedBindings primMap tcm + (netlist,dfiles,cmpCnt) <- genNetlist Nothing transformedBindings primMap' tcm typeTrans Nothing modName [] iw topEntity netlistTime <- netlist `deepseq` Clock.getCurrentTime @@ -83,7 +98,7 @@ cName) netlist - (testBench,dfiles') <- genTestBench opts supplyTB primMap + (testBench,dfiles') <- genTestBench opts supplyTB primMap' typeTrans tcm tupTcm eval cmpCnt bindingsMap testInpM expOutM @@ -97,7 +112,7 @@ putStrLn $ "Testbench generation took " ++ show netTBDiff let hdlState' = fromMaybe (initBackend iw :: backend) hdlState - topWrapper = mkTopWrapper primMap annM modName iw topComponent + topWrapper = mkTopWrapper primMap' annM modName iw topComponent hdlDocs = createHDL hdlState' modName (topWrapper : netlist ++ testBench) dir = concat [ "./" ++ CLaSH.Backend.name hdlState' ++ "/" , takeWhile (/= '.') (name2String topEntity) @@ -110,6 +125,14 @@ end <- hdlDocs `seq` Clock.getCurrentTime let startEndDiff = Clock.diffUTCTime end start putStrLn $ "Total compilation took " ++ show startEndDiff + +parsePrimitive :: Primitive Text -> Primitive BlackBoxTemplate +parsePrimitive (BlackBox pNm templT) = + let (templ,err) = either (first Left . runParse) (first Right . runParse) templT + in case err of + [] -> BlackBox pNm templ + _ -> error $ "Errors in template for: " ++ show pNm ++ ":\n" ++ show err +parsePrimitive (Primitive pNm typ) = Primitive pNm typ -- | Pretty print Components to HDL Documents createHDL :: Backend backend diff --git a/src/CLaSH/Driver/TestbenchGen.hs b/src/CLaSH/Driver/TestbenchGen.hs --- a/src/CLaSH/Driver/TestbenchGen.hs +++ b/src/CLaSH/Driver/TestbenchGen.hs @@ -1,8 +1,15 @@ +{-| + Copyright : (C) 2013-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Generate a HDL testbench for a component given a set of stimuli and a set of + matching expected outputs +-} + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} --- | Generate a HDL testbench for a component given a set of stimuli and a --- set of matching expected outputs module CLaSH.Driver.TestbenchGen ( genTestBench ) where @@ -25,7 +32,7 @@ import CLaSH.Netlist import CLaSH.Netlist.BlackBox (prepareBlackBox) -import CLaSH.Netlist.BlackBox.Types (Element (Err)) +import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate, Element (Err)) import CLaSH.Netlist.Types as N import CLaSH.Normalize (cleanupGraph, normalize, runNormalization) @@ -38,7 +45,7 @@ -- set of matching expected outputs genTestBench :: CLaSHOpts -> Supply - -> PrimMap -- ^ Primitives + -> PrimMap BlackBoxTemplate -- ^ Primitives -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -> HashMap TyConName TyCon -> IntMap TyConName @@ -102,11 +109,11 @@ -> TmName -> HashMap TmName (Type,Term) normalizeSignal glbls bndr = - runNormalization opts supply glbls typeTrans tcm tupTcm eval (normalize [bndr] >>= cleanupGraph bndr) + runNormalization opts supply glbls typeTrans tcm tupTcm eval primMap (normalize [bndr] >>= cleanupGraph bndr) genTestBench opts _ _ _ _ _ _ _ _ _ _ _ dfiles c = traceIf (opt_dbgLevel opts > DebugNone) ("Can't make testbench for: " ++ show c) $ return ([],dfiles) -genClock :: PrimMap +genClock :: PrimMap BlackBoxTemplate -> (Identifier,HWType) -> NetlistMonad (Maybe [Declaration]) genClock primMap (clkName,Clock clkSym rate) = @@ -131,7 +138,7 @@ genClock _ _ = return Nothing -genReset :: PrimMap +genReset :: PrimMap BlackBoxTemplate -> (Identifier,HWType) -> NetlistMonad (Maybe [Declaration]) genReset primMap (rstName,Reset clkSym rate) = @@ -152,7 +159,7 @@ genReset _ _ = return Nothing -genFinish :: PrimMap +genFinish :: PrimMap BlackBoxTemplate -> NetlistMonad Declaration genFinish primMap = case HashMap.lookup "CLaSH.Driver.TestbenchGen.finishedGen" primMap of Just (BlackBox _ (Left templ)) -> do @@ -164,7 +171,7 @@ return $ BlackBoxD "CLaSH.Driver.TestbenchGen.finishGen" templ' ctx pM -> error $ $(curLoc) ++ ("Can't make finish declaration for: " ++ show pM) -genDone :: PrimMap +genDone :: PrimMap BlackBoxTemplate -> NetlistMonad Declaration genDone primMap = case HashMap.lookup "CLaSH.Driver.TestbenchGen.doneGen" primMap of Just (BlackBox _ (Left templ)) -> do @@ -177,7 +184,7 @@ pM -> error $ $(curLoc) ++ ("Can't make done declaration for: " ++ show pM) genStimuli :: Int - -> PrimMap + -> PrimMap BlackBoxTemplate -> HashMap TmName (Type,Term) -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -> HashMap TyConName TyCon @@ -213,7 +220,7 @@ return (decl,comps,cmpCnt',hidden'',dfiles') genVerifier :: Int - -> PrimMap + -> PrimMap BlackBoxTemplate -> HashMap TmName (Type,Term) -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -> HashMap TyConName TyCon diff --git a/src/CLaSH/Driver/TopWrapper.hs b/src/CLaSH/Driver/TopWrapper.hs --- a/src/CLaSH/Driver/TopWrapper.hs +++ b/src/CLaSH/Driver/TopWrapper.hs @@ -1,3 +1,9 @@ +{-| + Copyright : (C) 2015-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} @@ -5,11 +11,6 @@ {-# OPTIONS_HADDOCK show-extensions #-} -{-| -Copyright : (C) 2015, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} module CLaSH.Driver.TopWrapper where import Data.Char (isDigit) @@ -23,6 +24,7 @@ import CLaSH.Netlist (runNetlistMonad) import CLaSH.Netlist.BlackBox (prepareBlackBox) +import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate) import CLaSH.Netlist.Types (BlackBoxContext (..), Component (..), Declaration (..), Expr (..), Identifier, HWType (..), Modifier (..), NetlistMonad, @@ -31,7 +33,7 @@ import CLaSH.Util -- | Create a wrapper around a component, potentially initiating clock sources -mkTopWrapper :: PrimMap +mkTopWrapper :: PrimMap BlackBoxTemplate -> Maybe TopEntity -- ^ TopEntity specifications -> String -- ^ Name of the module containing the @topEntity@ -> Int -- ^ Int/Word/Integer bit-width @@ -204,7 +206,7 @@ iName = append i (pack ("_" ++ show cnt)) -- | Create clock generators -mkClocks :: PrimMap -> [(Identifier,HWType)] -> Int -> Maybe TopEntity -> [Declaration] +mkClocks :: PrimMap BlackBoxTemplate -> [(Identifier,HWType)] -> Int -> Maybe TopEntity -> [Declaration] mkClocks primMap hidden iw teM = concat [ clockGens , resets @@ -249,7 +251,7 @@ clks = map snd outp -- | Generate resets -mkResets :: PrimMap +mkResets :: PrimMap BlackBoxTemplate -> [(Identifier,HWType)] -> Int -> [(Identifier,[String],Bool)] @@ -269,7 +271,7 @@ -- | Generate a reset synchroniser that synchronously de-asserts an -- asynchronous reset signal -genSyncReset :: PrimMap +genSyncReset :: PrimMap BlackBoxTemplate -> Identifier -> Identifier -> Text diff --git a/src/CLaSH/Driver/Types.hs b/src/CLaSH/Driver/Types.hs --- a/src/CLaSH/Driver/Types.hs +++ b/src/CLaSH/Driver/Types.hs @@ -1,4 +1,11 @@ --- | Type definitions used by the Driver module +{-| + Copyright : (C) 2013-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Type definitions used by the Driver module +-} + module CLaSH.Driver.Types where import Data.HashMap.Lazy (HashMap) diff --git a/src/CLaSH/Netlist.hs b/src/CLaSH/Netlist.hs --- a/src/CLaSH/Netlist.hs +++ b/src/CLaSH/Netlist.hs @@ -1,7 +1,14 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Create Netlists out of normalized CoreHW Terms +-} + {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} --- | Create Netlists out of normalized CoreHW Terms module CLaSH.Netlist where import Control.Lens ((.=), (<<%=)) @@ -31,6 +38,7 @@ import CLaSH.Core.Util (collectArgs, isVar, termType) import CLaSH.Core.Var (Id, Var (..)) import CLaSH.Netlist.BlackBox +import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate) import CLaSH.Netlist.Id import CLaSH.Netlist.Types as HW import CLaSH.Netlist.Util @@ -44,7 +52,7 @@ -- ^ Starting number of the component counter -> HashMap TmName (Type,Term) -- ^ Global binders - -> PrimMap + -> PrimMap BlackBoxTemplate -- ^ Primitive definitions -> HashMap TyConName TyCon -- ^ TyCon cache @@ -70,7 +78,7 @@ -- ^ Starting number of the component counter -> HashMap TmName (Type,Term) -- ^ Global binders - -> PrimMap + -> PrimMap BlackBoxTemplate -- ^ Primitive Definitions -> HashMap TyConName TyCon -- ^ TyCon cache diff --git a/src/CLaSH/Netlist.hs-boot b/src/CLaSH/Netlist.hs-boot --- a/src/CLaSH/Netlist.hs-boot +++ b/src/CLaSH/Netlist.hs-boot @@ -1,3 +1,9 @@ +{-| + Copyright : (C) 2015-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + module CLaSH.Netlist (genComponent,mkExpr,mkDcApplication) where import CLaSH.Core.DataCon (DataCon) diff --git a/src/CLaSH/Netlist/BlackBox.hs b/src/CLaSH/Netlist/BlackBox.hs --- a/src/CLaSH/Netlist/BlackBox.hs +++ b/src/CLaSH/Netlist/BlackBox.hs @@ -1,8 +1,15 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Functions to create BlackBox Contexts and fill in BlackBox templates +-} + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} --- | Functions to create BlackBox Contexts and fill in BlackBox templates module CLaSH.Netlist.BlackBox where import Control.Lens ((.=),(<<%=)) @@ -12,7 +19,7 @@ import Data.Either (lefts) import qualified Data.HashMap.Lazy as HashMap import qualified Data.IntMap as IntMap -import Data.Text.Lazy (Text, fromStrict, pack) +import Data.Text.Lazy (fromStrict, pack) import qualified Data.Text.Lazy as Text import Data.Text (unpack) import qualified Data.Text as TextS @@ -31,7 +38,6 @@ import CLaSH.Core.Var as V (Id, Var (..)) import {-# SOURCE #-} CLaSH.Netlist (genComponent, mkDcApplication, mkExpr) -import CLaSH.Netlist.BlackBox.Parser as B import CLaSH.Netlist.BlackBox.Types as B import CLaSH.Netlist.BlackBox.Util as B import CLaSH.Netlist.Id as N @@ -70,20 +76,18 @@ else return (im,[]) prepareBlackBox :: TextS.Text - -> Text + -> BlackBoxTemplate -> BlackBoxContext -> NetlistMonad BlackBoxTemplate -prepareBlackBox pNm t bbCtx = - let (templ,err) = runParse t - in if null err && verifyBlackBoxContext bbCtx templ - then instantiateSym >=> - setClocks bbCtx >=> - collectFilePaths bbCtx >=> - instantiateCompName $ templ - else - error $ $(curLoc) ++ "\nCan't match template for " ++ show pNm ++ " :\n" ++ show t ++ - "\nwith context:\n" ++ show bbCtx ++ "\ngiven errors:\n" ++ - show err +prepareBlackBox pNm templ bbCtx = + if verifyBlackBoxContext bbCtx templ + then instantiateSym >=> + setClocks bbCtx >=> + collectFilePaths bbCtx >=> + instantiateCompName $ templ + else + error $ $(curLoc) ++ "\nCan't match template for " ++ show pNm ++ " :\n" ++ show templ ++ + "\nwith context:\n" ++ show bbCtx mkArgument :: Term -> NetlistMonad ( (SyncExpr,HWType,Bool) @@ -255,17 +259,17 @@ Nothing -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e case templ of - Left (_, Left templ') -> let (l,err) = runParse templ' - in if null err - then do - l' <- instantiateSym l - l'' <- setClocks bbCtx l' - l3 <- instantiateCompName l'' - return ((Left l3,bbCtx),dcls) - else error $ $(curLoc) ++ "\nTemplate:\n" ++ show templ ++ "\nHas errors:\n" ++ show err - Left (_, Right templ') -> let ass = Assignment (pack "~RESULT") (Identifier templ' Nothing) - in return ((Right ass, bbCtx),dcls) - Right decl -> return ((Right decl,bbCtx),dcls) + Left (_, Left templ') -> do + l' <- instantiateSym templ' + l'' <- setClocks bbCtx l' + l3 <- instantiateCompName l'' + return ((Left l3,bbCtx),dcls) + Left (_, Right templ') -> do + templ'' <- prettyBlackBox templ' + let ass = Assignment (pack "~RESULT") (Identifier templ'' Nothing) + return ((Right ass, bbCtx),dcls) + Right decl -> + return ((Right decl,bbCtx),dcls) -- | Instantiate symbols references with a new symbol and increment symbol counter instantiateSym :: BlackBoxTemplate diff --git a/src/CLaSH/Netlist/BlackBox/Parser.hs b/src/CLaSH/Netlist/BlackBox/Parser.hs --- a/src/CLaSH/Netlist/BlackBox/Parser.hs +++ b/src/CLaSH/Netlist/BlackBox/Parser.hs @@ -1,4 +1,11 @@ --- | Parser definitions for BlackBox templates +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Parser definitions for BlackBox templates +-} + module CLaSH.Netlist.BlackBox.Parser (runParse) where @@ -82,6 +89,10 @@ <|> SigD <$> (pToken "~SIGD" *> pBrackets pSigD) <*> (Just <$> (pBrackets pNatural)) <|> (`SigD` Nothing) <$> (pToken "~SIGDO" *> pBrackets pSigD) <|> IW64 <$ pToken "~IW64" + <|> (BV True) <$> (pToken "~TOBV" *> pBrackets pSigD) <*> (Just <$> pBrackets pNatural) + <|> (BV True) <$> (pToken "~TOBVO" *> pBrackets pSigD) <*> pure Nothing + <|> (BV False) <$> (pToken "~FROMBV" *> pBrackets pSigD) <*> (Just <$> pBrackets pNatural) + <|> (BV False) <$> (pToken "~FROMBVO" *> pBrackets pSigD) <*> pure Nothing -- | Parse a bracketed text pBrackets :: Parser a -> Parser a @@ -102,7 +113,9 @@ -- | Parse SigD pSigD :: Parser [Element] -pSigD = pSome (pTagE <|> pLimitedText) +pSigD = pSome (pTagE <|> pLimitedText + <|> (C <$> (pack <$> pToken "[ ")) + <|> (C <$> (pack <$> pToken " ]"))) -- | Text excluding square brackets and tilde pLimitedText :: Parser Element diff --git a/src/CLaSH/Netlist/BlackBox/Types.hs b/src/CLaSH/Netlist/BlackBox/Types.hs --- a/src/CLaSH/Netlist/BlackBox/Types.hs +++ b/src/CLaSH/Netlist/BlackBox/Types.hs @@ -1,4 +1,11 @@ --- | Types used in BlackBox modules +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Types used in BlackBox modules +-} + module CLaSH.Netlist.BlackBox.Types where import Data.Text.Lazy (Text) @@ -32,6 +39,7 @@ | IF !Element [Element] [Element] | IW64 -- ^ Hole indicating whether Int/Word/Integer -- are 64-Bit + | BV Bool [Element] (Maybe Int) -- ^ Convert to (True)/from(False) a bit-vector | SigD [Element] !(Maybe Int) deriving Show diff --git a/src/CLaSH/Netlist/BlackBox/Util.hs b/src/CLaSH/Netlist/BlackBox/Util.hs --- a/src/CLaSH/Netlist/BlackBox/Util.hs +++ b/src/CLaSH/Netlist/BlackBox/Util.hs @@ -1,11 +1,18 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Utilties to verify blackbox contexts against templates and rendering filled + in templates +-} + {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} --- | Utilties to verify blackbox contexts against templates and rendering --- filled in templates module CLaSH.Netlist.BlackBox.Util where import Control.Lens (at, use, (%=), (+=), _1, @@ -14,7 +21,7 @@ import Control.Monad.Writer.Strict (MonadWriter, tell) import Data.Foldable (foldrM) import qualified Data.IntMap as IntMap -import Data.List (mapAccumL) +import Data.List (mapAccumL, nub) import Data.Set (Set,singleton) import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as Text @@ -22,7 +29,10 @@ takeBaseName, takeFileName) import Text.PrettyPrint.Leijen.Text.Monadic (displayT, renderCompact, - renderOneLine) + renderOneLine, brackets, + int, (<>), text, (<+>), + vcat, (<$$>), nest) +import qualified Text.PrettyPrint.Leijen.Text.Monadic as PP import CLaSH.Backend (Backend (..)) import CLaSH.Netlist.BlackBox.Parser @@ -82,6 +92,7 @@ D (Decl n l') -> D <$> (Decl n <$> mapM (combineM setSym' setSym') l') IF c t f -> IF <$> pure c <*> setSym' t <*> setSym' f SigD e' m -> SigD <$> (setSym' e') <*> pure m + BV t e' m -> BV <$> pure t <*> setSym' e' <*> pure m _ -> pure e ) @@ -102,6 +113,7 @@ setClocks' (D (Decl n l)) = D <$> (Decl n <$> mapM (combineM (setClocks bc) (setClocks bc)) l) setClocks' (IF c t f) = IF <$> pure c <*> setClocks bc t <*> setClocks bc f setClocks' (SigD e m) = SigD <$> (setClocks bc e) <*> pure m + setClocks' (BV t e m) = BV <$> pure t <*> setClocks bc e <*> pure m setClocks' (Clk Nothing) = let (clk,rate) = clkSyncId $ fst $ bbResult bc clkName = Text.append clk (Text.pack (show rate)) @@ -200,7 +212,7 @@ (either id fst -> Literal _ (NumLit i),_,_) -> fromInteger i _ -> error $ $(curLoc) ++ "IF: LIT must be a numeric lit" IW64 -> if iw == 64 then 1 else 0 - _ -> error $ $(curLoc) ++ "IF: condition must be: SIZE, LENGHT, IW64, or LIT" + _ -> error $ $(curLoc) ++ "IF: condition must be: SIZE, LENGTH, IW64, or LIT" if c' > 0 then renderBlackBox t b else renderBlackBox f b renderElem b e = renderTag b e @@ -261,6 +273,24 @@ mkLit i = i renderTag _ (Sym n) = return $ Text.pack ("n_" ++ show n) + +renderTag b (BV True es (Just n)) = do + e' <- Text.concat <$> mapM (renderElem b) es + let (_,hty,_) = bbInputs b !! n + (displayT . renderOneLine) <$> toBV hty e' +renderTag b (BV True es Nothing) = do + e' <- Text.concat <$> mapM (renderElem b) es + let (_,hty) = bbResult b + (displayT . renderOneLine) <$> toBV hty e' +renderTag b (BV False es (Just n)) = do + e' <- Text.concat <$> mapM (renderElem b) es + let (_,hty,_) = bbInputs b !! n + (displayT . renderOneLine) <$> fromBV hty e' +renderTag b (BV False es Nothing) = do + e' <- Text.concat <$> mapM (renderElem b) es + let (_,hty) = bbResult b + (displayT . renderOneLine) <$> fromBV hty e' + renderTag b (Typ Nothing) = fmap (displayT . renderOneLine) . hdlType . snd $ bbResult b renderTag b (Typ (Just n)) = let (_,ty,_) = bbInputs b !! n in (displayT . renderOneLine) <$> hdlType ty @@ -287,3 +317,93 @@ renderTag _ (IndexType _) = error $ $(curLoc) ++ "Unexpected index type" renderTag _ (FilePath _) = error $ $(curLoc) ++ "Unexpected file name" renderTag _ IW64 = error $ $(curLoc) ++ "Unexpected IW64" + +prettyBlackBox :: Monad m + => BlackBoxTemplate + -> m Text +prettyBlackBox bbT = Text.concat <$> mapM prettyElem bbT + +prettyElem :: Monad m + => Element + -> m Text +prettyElem (C t) = return t +prettyElem (D (Decl i args)) = do + args' <- mapM (\(a,b) -> (,) <$> prettyBlackBox a <*> prettyBlackBox b) args + (displayT . renderOneLine) <$> + (nest 2 (text "~INST" <+> int i <$$> + text "~OUTPUT" <+> text "=>" <+> text (fst (head args')) <+> text (snd (head args')) <+> text "~" <$$> + vcat (mapM (\(a,b) -> text "~INPUT" <+> text "=>" <+> text a <+> text b <+> text "~") (tail args'))) + PP.<$$> text "~INST") +prettyElem O = return "~RESULT" +prettyElem (I i) = (displayT . renderOneLine) <$> (text "~ARG" <> brackets (int i)) +prettyElem (L i) = (displayT . renderOneLine) <$> (text "~LIT" <> brackets (int i)) +prettyElem (Sym i) = (displayT . renderOneLine) <$> (text "~SYM" <> brackets (int i)) +prettyElem (Clk Nothing) = return "~CLKO" +prettyElem (Clk (Just i)) = (displayT . renderOneLine) <$> (text "~CLK" <> brackets (int i)) +prettyElem (Rst Nothing) = return "~RSTO" +prettyElem (Rst (Just i)) = (displayT . renderOneLine) <$> (text "~RSTO" <> brackets (int i)) +prettyElem (Typ Nothing) = return "~TYPO" +prettyElem (Typ (Just i)) = (displayT . renderOneLine) <$> (text "~TYPO" <> brackets (int i)) +prettyElem (TypM Nothing) = return "~TYPMO" +prettyElem (TypM (Just i)) = (displayT . renderOneLine) <$> (text "~TYPM" <> brackets (int i)) +prettyElem (Err Nothing) = return "~ERRORO" +prettyElem (Err (Just i)) = (displayT . renderOneLine) <$> (text "~ERROR" <> brackets (int i)) +prettyElem (TypElem e) = do + e' <- prettyElem e + (displayT . renderOneLine) <$> (text "~TYPEL" <> brackets (text e')) +prettyElem CompName = return "~COMPNAME" +prettyElem (IndexType e) = do + e' <- prettyElem e + (displayT . renderOneLine) <$> (text "~INDEXTYPE" <> brackets (text e')) +prettyElem (Size e) = do + e' <- prettyElem e + (displayT . renderOneLine) <$> (text "~SIZE" <> brackets (text e')) +prettyElem (Length e) = do + e' <- prettyElem e + (displayT . renderOneLine) <$> (text "~LENGTH" <> brackets (text e')) +prettyElem (FilePath e) = do + e' <- prettyElem e + (displayT . renderOneLine) <$> (text "~FILE" <> brackets (text e')) +prettyElem (Gen b) = if b then return "~GENERATE" else return "~ENDGENERATE" +prettyElem (IF b esT esF) = do + b' <- prettyElem b + esT' <- prettyBlackBox esT + esF' <- prettyBlackBox esF + (displayT . renderCompact) <$> + (text "~IF" <+> text b' <+> text "~THEN" PP.<$> + text esT' PP.<$> + text "~ELSE" PP.<$> + text esF' PP.<$> + text "~FI") +prettyElem IW64 = return "~IW64" +prettyElem (BV b es mI) = do + es' <- prettyBlackBox es + (displayT . renderOneLine) <$> + if b + then maybe (text "~TOBVO" <> brackets (text es')) + (((text "~TOBV" <> brackets (text es')) <>) . int) + mI + else maybe (text "~FROMBVO" <> brackets (text es')) + (((text "~FROMBV" <> brackets (text es')) <>) . int) + mI +prettyElem (SigD es mI) = do + es' <- prettyBlackBox es + (displayT . renderOneLine) <$> + (maybe (text "~SIGDO" <> brackets (text es')) + (((text "~SIGD" <> brackets (text es')) <>) . int) + mI) + +usedArguments :: BlackBoxTemplate + -> [Int] +usedArguments = nub . concatMap go + where + go x = case x of + D (Decl i args) -> i : concatMap (\(a,b) -> usedArguments a ++ usedArguments b) args + I i -> [i] + L i -> [i] + IndexType e -> go e + FilePath e -> go e + IF b esT esF -> go b ++ usedArguments esT ++ usedArguments esF + SigD es _ -> usedArguments es + BV _ es _ -> usedArguments es + _ -> [] diff --git a/src/CLaSH/Netlist/Id.hs b/src/CLaSH/Netlist/Id.hs --- a/src/CLaSH/Netlist/Id.hs +++ b/src/CLaSH/Netlist/Id.hs @@ -1,7 +1,15 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Transform/format a Netlist Identifier so that it is acceptable as a HDL identifier +-} + {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} --- | Transform/format a Netlist Identifier so that it is acceptable as a HDL identifier + module CLaSH.Netlist.Id ( mkBasicId , mkBasicId' diff --git a/src/CLaSH/Netlist/Types.hs b/src/CLaSH/Netlist/Types.hs --- a/src/CLaSH/Netlist/Types.hs +++ b/src/CLaSH/Netlist/Types.hs @@ -1,8 +1,15 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Type and instance definitions for Netlist modules +-} + {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} --- | Type and instance definitions for Netlist modules module CLaSH.Netlist.Types where import Control.DeepSeq @@ -44,7 +51,7 @@ , _varCount :: !Int -- ^ Number of signal declarations , _cmpCount :: !Int -- ^ Number of create components , _components :: HashMap TmName Component -- ^ Cached components - , _primitives :: PrimMap -- ^ Primitive Definitions + , _primitives :: PrimMap BlackBoxTemplate -- ^ Primitive Definitions , _typeTranslator :: HashMap TyConName TyCon -> Type -> Maybe (Either String HWType) -- ^ Hardcoded Type -> HWType translator , _tcCache :: HashMap TyConName TyCon -- ^ TyCon cache , _modNm :: !String -- ^ Name of the module containing the @topEntity@ diff --git a/src/CLaSH/Netlist/Util.hs b/src/CLaSH/Netlist/Util.hs --- a/src/CLaSH/Netlist/Util.hs +++ b/src/CLaSH/Netlist/Util.hs @@ -1,7 +1,14 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Utilities for converting Core Type/Term to Netlist datatypes +-} + {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} --- | Utilities for converting Core Type/Term to Netlist datatypes module CLaSH.Netlist.Util where import Control.Error (hush) diff --git a/src/CLaSH/Normalize.hs b/src/CLaSH/Normalize.hs --- a/src/CLaSH/Normalize.hs +++ b/src/CLaSH/Normalize.hs @@ -1,6 +1,13 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Turn CoreHW terms into normalized CoreHW Terms +-} + {-# LANGUAGE TemplateHaskell #-} --- | Turn CoreHW terms into normalized CoreHW Terms module CLaSH.Normalize where import Control.Concurrent.Supply (Supply) @@ -21,11 +28,12 @@ import CLaSH.Core.Pretty (showDoc) import CLaSH.Core.Subst (substTms) import CLaSH.Core.Term (Term (..), TmName) -import CLaSH.Core.Type (Type, splitFunForallTy) +import CLaSH.Core.Type (Type, splitCoreFunForallTy) import CLaSH.Core.TyCon (TyCon, TyConName) import CLaSH.Core.Util (collectArgs, mkApps, termType) import CLaSH.Core.Var (Id,varName) import CLaSH.Driver.Types (CLaSHOpts (..)) +import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate) import CLaSH.Netlist.Types (HWType) import CLaSH.Netlist.Util (splitNormalized) import CLaSH.Normalize.Strategy @@ -33,6 +41,7 @@ reduceConst, topLet ) import CLaSH.Normalize.Types import CLaSH.Normalize.Util +import CLaSH.Primitives.Types (PrimMap) import CLaSH.Rewrite.Combinators ((>->),(!->),repeatR,topdownR) import CLaSH.Rewrite.Types (DebugLevel (..), RewriteEnv (..), RewriteState (..), bindings, curFun, dbgLevel, @@ -57,10 +66,12 @@ -- ^ Tuple TyCon cache -> (HashMap TyConName TyCon -> Bool -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction) + -> PrimMap BlackBoxTemplate + -- ^ Primitive Definitions -> NormalizeSession a -- ^ NormalizeSession to run -> a -runNormalization opts supply globals typeTrans tcm tupTcm eval +runNormalization opts supply globals typeTrans tcm tupTcm eval primMap = runRewriteSession rwEnv rwState where rwEnv = RewriteEnv @@ -86,6 +97,7 @@ HashMap.empty (opt_inlineLimit opts) (opt_inlineBelow opts) + primMap normalize :: [TmName] @@ -103,14 +115,14 @@ let nmS = showDoc nm case exprM of Just (ty,tm) -> do - let (_,resTy) = splitFunForallTy ty + tcm <- Lens.view tcCache + let (_,resTy) = splitCoreFunForallTy tcm ty resTyRep <- not <$> isUntranslatableType resTy if resTyRep then do tmNorm <- makeCached nm (extra.normalized) $ do curFun .= nm tm' <- rewriteExpr ("normalization",normalization) (nmS,tm) - tcm <- Lens.view tcCache ty' <- termType tcm tm' return (ty',tm') let usedBndrs = Lens.toListOf termFreeIds (snd tmNorm) diff --git a/src/CLaSH/Normalize/DEC.hs b/src/CLaSH/Normalize/DEC.hs --- a/src/CLaSH/Normalize/DEC.hs +++ b/src/CLaSH/Normalize/DEC.hs @@ -1,3 +1,31 @@ +{-| + Copyright : (C) 2015-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Helper functions for the 'disjointExpressionConsolidation' transformation + + The 'disjointExpressionConsolidation' transformation lifts applications of + global binders out of alternatives of case-statements. + + e.g. It converts: + + > case x of + > A -> f 3 y + > B -> f x x + > C -> h x + + into: + + > let f_arg0 = case x of {A -> 3; B -> x} + > f_arg1 = case x of {A -> y; B -> x} + > f_out = f f_arg0 f_arg1 + > in case x of + > A -> f_out + > B -> f_out + > C -> h x +-} + {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE OverloadedStrings #-} @@ -6,31 +34,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} --- | Helper functions for the 'disjointExpressionConsolidation' transformation --- --- The 'disjointExpressionConsolidation' transformation lifts applications of --- global binders out of alternatives of case-statements. --- --- e.g. It converts: --- --- @ --- case x of --- A -> f 3 y --- B -> f x x --- C -> h x --- @ --- --- into: --- --- @ --- let f_arg0 = case x of {A -> 3; B -> x} --- f_arg1 = case x of {A -> y; B -> x} --- f_out = f f_arg0 f_arg1 --- in case x of --- A -> f_out --- B -> f_out --- C -> h x --- @ module CLaSH.Normalize.DEC (collectGlobals ,isDisjoint diff --git a/src/CLaSH/Normalize/PrimitiveReductions.hs b/src/CLaSH/Normalize/PrimitiveReductions.hs --- a/src/CLaSH/Normalize/PrimitiveReductions.hs +++ b/src/CLaSH/Normalize/PrimitiveReductions.hs @@ -1,26 +1,33 @@ +{-| + Copyright : (C) 2015-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Reductions of primitives + + Currently, it contains reductions for: + + * CLaSH.Sized.Vector.map + * CLaSH.Sized.Vector.zipWith + * CLaSH.Sized.Vector.traverse# + * CLaSH.Sized.Vector.foldr + * CLaSH.Sized.Vector.fold + * CLaSH.Sized.Vector.dfold + * CLaSH.Sized.Vector.(++) + * CLaSH.Sized.Vector.head + * CLaSH.Sized.Vector.tail + * CLaSH.Sized.Vector.unconcatBitVector# + * CLaSH.Sized.Vector.replicate + + Partially handles: + + * CLaSH.Sized.Vector.unconcat + * CLaSH.Sized.Vector.transpose +-} + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} --- | Reductions of primitives --- --- Currently, it contains reductions for: --- --- * CLaSH.Sized.Vector.map --- * CLaSH.Sized.Vector.zipWith --- * CLaSH.Sized.Vector.traverse# --- * CLaSH.Sized.Vector.foldr --- * CLaSH.Sized.Vector.fold --- * CLaSH.Sized.Vector.dfold --- * CLaSH.Sized.Vector.(++) --- * CLaSH.Sized.Vector.head --- * CLaSH.Sized.Vector.tail --- * CLaSH.Sized.Vector.unconcatBitVector# --- * CLaSH.Sized.Vector.replicate --- --- Partially handles: --- --- * CLaSH.Sized.Vector.unconcat --- * CLaSH.Sized.Vector.transpose module CLaSH.Normalize.PrimitiveReductions where import qualified Control.Lens as Lens diff --git a/src/CLaSH/Normalize/Strategy.hs b/src/CLaSH/Normalize/Strategy.hs --- a/src/CLaSH/Normalize/Strategy.hs +++ b/src/CLaSH/Normalize/Strategy.hs @@ -1,4 +1,11 @@ --- | Transformation process for normalization +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Transformation process for normalization +-} + module CLaSH.Normalize.Strategy where import CLaSH.Normalize.Transformations @@ -9,13 +16,14 @@ -- | Normalisation transformation normalization :: NormRewrite -normalization = etaTL >-> constantPropgation >-!-> anf >-!-> rmDeadcode >-> +normalization = etaTL >-> constantPropgation >-> rmUnusedExpr >-!-> anf >-!-> rmDeadcode >-> bindConst >-> letTL >-> evalConst >-!-> cse >-!-> recLetRec where etaTL = apply "etaTL" etaExpansionTL anf = topdownR (apply "nonRepANF" nonRepANF) >-> apply "ANF" makeANF letTL = topdownSucR (apply "topLet" topLet) recLetRec = apply "recToLetRec" recToLetRec + rmUnusedExpr = bottomupR (apply "removeUnusedExpr" removeUnusedExpr) rmDeadcode = topdownR (apply "deadcode" deadCode) bindConst = topdownR (apply "bindConstantVar" bindConstantVar) evalConst = topdownR (apply "evalConst" reduceConst) diff --git a/src/CLaSH/Normalize/Transformations.hs b/src/CLaSH/Normalize/Transformations.hs --- a/src/CLaSH/Normalize/Transformations.hs +++ b/src/CLaSH/Normalize/Transformations.hs @@ -1,8 +1,15 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Transformations of the Normalization process +-} + {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} --- | Transformations of the Normalization process module CLaSH.Normalize.Transformations ( appProp , bindNonRep @@ -29,6 +36,7 @@ , reduceNonRepPrim , caseFlat , disjointExpressionConsolidation + , removeUnusedExpr ) where @@ -41,6 +49,7 @@ import qualified Data.HashMap.Lazy as HashMap import qualified Data.List as List import qualified Data.Maybe as Maybe +import qualified Data.Set as Set import qualified Data.Set.Lens as Lens import Data.Text (Text, unpack) import Unbound.Generics.LocallyNameless (Bind, Embed (..), bind, embed, @@ -58,7 +67,7 @@ import CLaSH.Core.Type (TypeView (..), applyFunTy, applyTy, isPolyFunCoreTy, splitFunTy, typeKind, - tyView) + tyView, undefinedTy) import CLaSH.Core.TyCon (tyConDataCons) import CLaSH.Core.Util (collectArgs, idToVar, isCon, isFun, isLet, isPolyFun, isPrim, @@ -66,12 +75,14 @@ mkLams, mkTmApps, mkVec, termSize, termType, tyNatSize) import CLaSH.Core.Var (Id, Var (..)) +import CLaSH.Netlist.BlackBox.Util (usedArguments) import CLaSH.Netlist.Util (representableType, splitNormalized) import CLaSH.Normalize.DEC import CLaSH.Normalize.PrimitiveReductions import CLaSH.Normalize.Types import CLaSH.Normalize.Util +import CLaSH.Primitives.Types (Primitive (..)) import CLaSH.Rewrite.Combinators import CLaSH.Rewrite.Types import CLaSH.Rewrite.Util @@ -247,6 +258,10 @@ | nm == "Control.Exception.Base.patError" -> let e' = mkApps (Prim nm ty') [Right ty,msg] in changed e' + (Prim nm ty',[_]) + | nm == "GHC.Err.undefined" -> + let e' = mkApps (Prim nm ty') [Right ty] + in changed e' _ -> traceIf (lvl > DebugNone) ("Irreducible constant as case subject: " ++ showDoc subj ++ "\nCan be reduced to: " ++ showDoc subj') (caseOneAlt e) @@ -345,6 +360,49 @@ in findUsedBndrs (used ++ explore) explore' other' deadCode _ e = return e + +removeUnusedExpr :: NormRewrite +removeUnusedExpr _ e@(collectArgs -> (p@(Prim nm _),args)) = do + bbM <- HashMap.lookup nm <$> Lens.use (extra.primitives) + case bbM of + Just (BlackBox pNm templ) -> do + let usedArgs = if pNm `elem` ["CLaSH.Sized.Internal.Signed.fromInteger#" + ,"CLaSH.Sized.Internal.Unsigned.fromInteger#" + ,"CLaSH.Sized.Internal.BitVector.fromInteger#" + ,"CLaSH.Sized.Internal.Index.fromInteger#" + ] + then [0,1] + else either usedArguments usedArguments templ + tcm <- Lens.view tcCache + args' <- go tcm 0 usedArgs args + if args == args' + then return e + else changed (mkApps p args') + _ -> return e + where + go _ _ _ [] = return [] + go tcm n used (Right ty:args') = do + args'' <- go tcm n used args' + return (Right ty : args'') + go tcm n used (Left tm : args') = do + args'' <- go tcm (n+1) used args' + ty <- termType tcm tm + let p' = mkApps (Prim "CLaSH.Transformations.removedArg" undefinedTy) [Right ty] + if n `elem` used + then return (Left tm : args'') + else return (Left p' : args'') + +removeUnusedExpr _ e@(Case _ _ [alt]) = do + (pat,altExpr) <- unbind alt + case pat of + DataPat _ (unrebind -> ([],xs)) -> do + let altFreeIds = Lens.setOf termFreeIds altExpr + if Set.null (Set.intersection (Set.fromList (map varName xs)) altFreeIds) + then changed altExpr + else return e + _ -> return e + +removeUnusedExpr _ e = return e -- | Inline let-bindings when the RHS is either a local variable reference or -- is constant diff --git a/src/CLaSH/Normalize/Types.hs b/src/CLaSH/Normalize/Types.hs --- a/src/CLaSH/Normalize/Types.hs +++ b/src/CLaSH/Normalize/Types.hs @@ -1,14 +1,24 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Types used in Normalize modules +-} + {-# LANGUAGE TemplateHaskell #-} --- | Types used in Normalize modules + module CLaSH.Normalize.Types where import Control.Monad.State.Strict (State) import Data.HashMap.Strict (HashMap) import Data.Map (Map) -import CLaSH.Core.Term (Term, TmName) -import CLaSH.Core.Type (Type) -import CLaSH.Rewrite.Types (Rewrite, RewriteMonad) +import CLaSH.Core.Term (Term, TmName) +import CLaSH.Core.Type (Type) +import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate) +import CLaSH.Primitives.Types (PrimMap) +import CLaSH.Rewrite.Types (Rewrite, RewriteMonad) import CLaSH.Util -- | State of the 'NormalizeMonad' @@ -37,6 +47,7 @@ , _inlineBelow :: !Int -- ^ Size of a function below which it is always inlined if it is not -- recursive + , _primitives :: PrimMap BlackBoxTemplate -- ^ Primitive Definitions } makeLenses ''NormalizeState diff --git a/src/CLaSH/Normalize/Util.hs b/src/CLaSH/Normalize/Util.hs --- a/src/CLaSH/Normalize/Util.hs +++ b/src/CLaSH/Normalize/Util.hs @@ -1,7 +1,14 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Utility functions used by the normalisation transformations +-} + {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} --- | Utility functions used by the normalisation transformations module CLaSH.Normalize.Util where import Control.Lens ((%=)) diff --git a/src/CLaSH/Primitives/Types.hs b/src/CLaSH/Primitives/Types.hs --- a/src/CLaSH/Primitives/Types.hs +++ b/src/CLaSH/Primitives/Types.hs @@ -1,7 +1,15 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Type and instance definitions for Primitive +-} + +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} --- | Type and instance definitions for Primitive module CLaSH.Primitives.Types where import Control.Applicative ((<|>)) @@ -12,14 +20,14 @@ import Data.Text.Lazy (Text) -- | Primitive Definitions -type PrimMap = HashMap S.Text Primitive +type PrimMap a = HashMap S.Text (Primitive a) -- | Externally defined primitive -data Primitive +data Primitive a -- | A primitive that has a template that can be filled out by the backend render = BlackBox { name :: !S.Text -- ^ Name of the primitive - , template :: !(Either Text Text) -- ^ Either a /declaration/ or an /expression/ template. + , template :: !(Either a a) -- ^ Either a /declaration/ or an /expression/ template. } -- | A primitive that carries additional information | Primitive @@ -28,7 +36,7 @@ } deriving Show -instance FromJSON Primitive where +instance FromJSON (Primitive Text) where parseJSON (Object v) = case H.toList v of [(conKey,Object conVal)] -> case conKey of "BlackBox" -> BlackBox <$> conVal .: "name" <*> ((Left <$> conVal .: "templateD") <|> (Right <$> conVal .: "templateE")) diff --git a/src/CLaSH/Primitives/Util.hs b/src/CLaSH/Primitives/Util.hs --- a/src/CLaSH/Primitives/Util.hs +++ b/src/CLaSH/Primitives/Util.hs @@ -1,4 +1,11 @@ --- | Utility functions to generate Primitives +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Utility functions to generate Primitives +-} + module CLaSH.Primitives.Util where import Data.Aeson.Extra (decodeAndReport) @@ -6,6 +13,7 @@ import qualified Data.HashMap.Lazy as HashMap import Data.List (isSuffixOf) import Data.Maybe (fromMaybe) +import Data.Text.Lazy (Text) import qualified System.Directory as Directory import qualified System.FilePath as FilePath @@ -15,7 +23,7 @@ -- | Generate a set of primitives that are found in the primitive definition -- files in the given directories. generatePrimMap :: [FilePath] -- ^ Directories to search for primitive definitions - -> IO PrimMap + -> IO (PrimMap Text) generatePrimMap filePaths = do primitiveFiles <- fmap concat $ mapM (\filePath -> diff --git a/src/CLaSH/Rewrite/Combinators.hs b/src/CLaSH/Rewrite/Combinators.hs --- a/src/CLaSH/Rewrite/Combinators.hs +++ b/src/CLaSH/Rewrite/Combinators.hs @@ -1,6 +1,13 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Rewriting combinators and traversals +-} + {-# LANGUAGE ScopedTypeVariables #-} --- | Rewriting combinators and traversals module CLaSH.Rewrite.Combinators where import Control.DeepSeq (deepseq) diff --git a/src/CLaSH/Rewrite/Types.hs b/src/CLaSH/Rewrite/Types.hs --- a/src/CLaSH/Rewrite/Types.hs +++ b/src/CLaSH/Rewrite/Types.hs @@ -1,9 +1,16 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Type and instance definitions for Rewrite modules +-} + {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} --- | Type and instance definitions for Rewrite modules module CLaSH.Rewrite.Types where import Control.Concurrent.Supply (Supply, freshId) diff --git a/src/CLaSH/Rewrite/Util.hs b/src/CLaSH/Rewrite/Util.hs --- a/src/CLaSH/Rewrite/Util.hs +++ b/src/CLaSH/Rewrite/Util.hs @@ -1,7 +1,14 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Utilities for rewriting: e.g. inlining, specialisation, etc. +-} + {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TemplateHaskell #-} --- | Utilities for rewriting: e.g. inlining, specialisation, etc. module CLaSH.Rewrite.Util where import Control.DeepSeq diff --git a/src/CLaSH/Util.hs b/src/CLaSH/Util.hs --- a/src/CLaSH/Util.hs +++ b/src/CLaSH/Util.hs @@ -1,3 +1,11 @@ +{-| + Copyright : (C) 2012-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + Assortment of utility function used in the CLaSH library +-} + {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Rank2Types #-} @@ -5,7 +13,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} --- | Assortment of utility function used in the CLaSH library module CLaSH.Util ( module CLaSH.Util , module X diff --git a/src/Data/Aeson/Extra.hs b/src/Data/Aeson/Extra.hs --- a/src/Data/Aeson/Extra.hs +++ b/src/Data/Aeson/Extra.hs @@ -1,3 +1,9 @@ +{-| + Copyright : (C) 2015-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + module Data.Aeson.Extra where import Data.Aeson (FromJSON, Result (..), fromJSON, json) diff --git a/src/Unbound/Generics/LocallyNameless/Extra.hs b/src/Unbound/Generics/LocallyNameless/Extra.hs --- a/src/Unbound/Generics/LocallyNameless/Extra.hs +++ b/src/Unbound/Generics/LocallyNameless/Extra.hs @@ -1,3 +1,9 @@ +{-| + Copyright : (C) 2015-2016, University of Twente + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}