diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package +## 0.6.17 *April 7th 2016* +* New features: + * Up to 2x reduced compilation times when working with large `Vec` literals +* Fixes bugs: + * VHDL: Incorrect primitives for `BitVector`s `quot#` and `rem#` + * VHDL: Bit indexing and replacement primitives fail to synthesise in Synopsis tools + * Bug in DEC transformation throws CLaSH into an endless loop [#140](https://github.com/clash-lang/clash-compiler/issues/140) + * Missed constant folding opportunity results in an error [#50](https://github.com/clash-lang/clash-prelude/issues/50) + ## 0.6.16 *March 21st 2016* * New features: * Also generate testbench for circuits without input ports [#135](https://github.com/clash-lang/clash-compiler/issues/135) diff --git a/clash-ghc.cabal b/clash-ghc.cabal --- a/clash-ghc.cabal +++ b/clash-ghc.cabal @@ -1,5 +1,5 @@ Name: clash-ghc -Version: 0.6.16 +Version: 0.6.17 Synopsis: CAES Language for Synchronous Hardware Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -94,13 +94,15 @@ unbound-generics >= 0.1 && < 0.4, unordered-containers >= 0.2.1.0, - clash-lib >= 0.6.14 && < 0.7, + clash-lib >= 0.6.15 && < 0.7, clash-systemverilog >= 0.6.6, - clash-vhdl >= 0.6.10, + clash-vhdl >= 0.6.11, clash-verilog >= 0.6.6, clash-prelude >= 0.10.6 && < 0.11, ghc-typelits-extra >= 0.1, - ghc-typelits-natnormalise >= 0.3 + ghc-typelits-natnormalise >= 0.3, + deepseq >= 1.3.0.2, + time >= 1.4.0.1 if os(windows) Build-Depends: Win32 diff --git a/src-bin/InteractiveUI.hs b/src-bin/InteractiveUI.hs --- a/src-bin/InteractiveUI.hs +++ b/src-bin/InteractiveUI.hs @@ -117,6 +117,8 @@ import CLaSH.Netlist.BlackBox.Types (HdlSyn) import qualified CLaSH.Primitives.Util import CLaSH.Util (clashLibVersion) +import Control.DeepSeq +import qualified Data.Time.Clock as Clock import qualified Data.Version as Data.Version import qualified Paths_clash_ghc @@ -1577,7 +1579,8 @@ -> m () makeHDL backend optsRef srcs = do dflags <- GHC.getSessionDynFlags - liftIO $ do opts <- readIORef optsRef + liftIO $ do startTime <- Clock.getCurrentTime + opts <- readIORef optsRef let iw = opt_intWidth opts syn = opt_hdlSyn opts -- determine whether `-outputdir` was used @@ -1593,8 +1596,11 @@ primMap <- CLaSH.Primitives.Util.generatePrimMap [primDir,"."] forM_ srcs $ \src -> do (bindingsMap,tcm,tupTcm,topEnt,testInpM,expOutM) <- generateBindings primMap src (Just dflags) + prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime + let prepStartDiff = Clock.diffUTCTime prepTime startTime + putStrLn $ "Loading dependencies took " ++ show prepStartDiff CLaSH.Driver.generateHDL bindingsMap (Just (backend iw syn)) primMap tcm - tupTcm (ghcTypeToHWType iw) reduceConstant topEnt testInpM expOutM opts' + tupTcm (ghcTypeToHWType iw) reduceConstant topEnt testInpM expOutM opts' (startTime,prepTime) makeVHDL :: IORef CLaSHOpts -> [FilePath] -> InputT GHCi () makeVHDL = makeHDL' (CLaSH.Backend.initBackend :: Int -> HdlSyn -> VHDLState) diff --git a/src-ghc/CLaSH/GHC/Evaluator.hs b/src-ghc/CLaSH/GHC/Evaluator.hs --- a/src-ghc/CLaSH/GHC/Evaluator.hs +++ b/src-ghc/CLaSH/GHC/Evaluator.hs @@ -4,7 +4,7 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} module CLaSH.GHC.Evaluator where @@ -14,6 +14,7 @@ import qualified Data.Either as Either import qualified Data.HashMap.Strict as HashMap import qualified Data.List as List +import Data.Text (Text) import Unbound.Generics.LocallyNameless (runFreshM, bind, embed, string2Name) @@ -29,213 +30,308 @@ import CLaSH.Core.Var (Var (..)) reduceConstant :: HashMap.HashMap TyConName TyCon -> Bool -> Term -> Term -reduceConstant tcm isSubj e@(collectArgs -> (Prim nm ty, args)) - | nm == "GHC.Prim.==#" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntLiteral i), Literal (IntLiteral j)] - | i == j -> Literal (IntLiteral 1) - | otherwise -> Literal (IntLiteral 0) - _ -> e - | nm == "GHC.Integer.Type.eqInteger#" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] - | i == j -> Literal (IntLiteral 1) - | otherwise -> Literal (IntLiteral 0) - _ -> e - | nm == "GHC.Prim.>#" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntLiteral i), Literal (IntLiteral j)] - | i > j -> Literal (IntLiteral 1) - | otherwise -> Literal (IntLiteral 0) - _ -> e - | nm == "GHC.Integer.Type.gtInteger#" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] - | i > j -> Literal (IntLiteral 1) - | otherwise -> Literal (IntLiteral 0) - _ -> e - | nm == "GHC.Prim.<#" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntLiteral i), Literal (IntLiteral j)] - | i < j -> Literal (IntLiteral 1) - | otherwise -> Literal (IntLiteral 0) - _ -> e - | nm == "GHC.Integer.Type.ltInteger#" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] - | i < j -> Literal (IntLiteral 1) - | otherwise -> Literal (IntLiteral 0) - _ -> e - | nm == "GHC.Prim.<=#" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntLiteral i), Literal (IntLiteral j)] - | i <= j -> Literal (IntLiteral 1) - | otherwise -> Literal (IntLiteral 0) - _ -> e - | nm == "GHC.Integer.Type.leInteger#" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] - | i <= j -> Literal (IntLiteral 1) - | otherwise -> Literal (IntLiteral 0) - _ -> e - | nm == "GHC.Prim.>=#" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntLiteral i), Literal (IntLiteral j)] - | i >= j -> Literal (IntLiteral 1) - | otherwise -> Literal (IntLiteral 0) - _ -> e - | nm == "GHC.Integer.Type.geInteger#" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] - | i >= j -> Literal (IntLiteral 1) - | otherwise -> Literal (IntLiteral 0) - _ -> e - | nm == "GHC.Integer.Type.integerToInt" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntegerLiteral i)] -> Literal (IntLiteral i) - _ -> e - | nm == "GHC.Prim.tagToEnum#" - = case map (Bifunctor.bimap (reduceConstant tcm isSubj) id) args of - [Right (ConstTy (TyCon tcN)), Left (Literal (IntLiteral i))] -> - let dc = do { tc <- HashMap.lookup tcN tcm - ; let dcs = tyConDataCons tc - ; List.find ((== (i+1)) . toInteger . dcTag) dcs - } - in maybe e Data dc - _ -> e - | nm == "GHC.Prim.*#" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntLiteral i), Literal (IntLiteral j)] - -> Literal (IntLiteral (i * j)) - _ -> e - | nm == "GHC.Integer.Type.eqInteger" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] - -> let (_,tyView -> TyConApp boolTcNm []) = splitFunForallTy ty - (Just boolTc) = HashMap.lookup boolTcNm tcm - [falseDc,trueDc] = tyConDataCons boolTc - retDc = if i == j then trueDc else falseDc - in Data retDc - _ -> e - | nm == "GHC.Integer.Type.minusInteger" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] - -> Literal (IntegerLiteral (i - j)) - _ -> e - | nm == "GHC.Integer.Type.divInteger" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] - -> Literal (IntegerLiteral (i `div` j)) - _ -> e - | nm == "GHC.Integer.Type.quotInteger" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] - -> Literal (IntegerLiteral (i `quot` j)) - _ -> e - | nm == "GHC.Integer.Type.remInteger" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] - -> Literal (IntegerLiteral (i `rem` j)) - _ -> e - | nm == "GHC.Prim.quotRemInt#" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntLiteral i), Literal (IntLiteral j)] - -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty - (Just tupTc) = HashMap.lookup tupTcNm tcm - [tupDc] = tyConDataCons tupTc - (q,r) = quotRem i j - ret = mkApps (Data tupDc) (map Right tyArgs ++ [Left (Literal (IntLiteral q)), Left (Literal (IntLiteral r))]) - in ret - _ -> e - | nm == "GHC.Integer.Type.shiftLInteger" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntegerLiteral i), Literal (IntLiteral j)] - -> Literal (IntegerLiteral (i `shiftL` fromInteger j)) - _ -> e - | nm == "GHC.Integer.Type.shiftRInteger" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntegerLiteral i), Literal (IntLiteral j)] - -> Literal (IntegerLiteral (i `shiftR` fromInteger j)) - _ -> e - | nm == "GHC.Prim.negateInt#" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntLiteral i)] -> Literal (IntLiteral (negate i)) - _ -> e - | nm == "CLaSH.Sized.Internal.Signed.minBound#" - = case args of - [litTy,kn@(Left (Literal (IntegerLiteral mb)))] - -> let minB = negate (2 ^ (mb - 1)) - in mkApps signedConPrim [litTy,kn,Left (Literal (IntegerLiteral minB))] - _ -> e - | nm == "CLaSH.Sized.Internal.Signed.maxBound#" - = case args of - [litTy,kn@(Left (Literal (IntegerLiteral mb)))] - -> let maxB = (2 ^ (mb - 1)) - 1 - in mkApps signedConPrim [litTy,kn,Left (Literal (IntegerLiteral maxB))] - _ -> e - | nm == "CLaSH.Sized.Internal.Unsigned.minBound#" - = case args of - [litTy,kn@(Left (Literal (IntegerLiteral _)))] - -> mkApps unsignedConPrim [litTy,kn,Left (Literal (IntegerLiteral 0))] - _ -> e - | nm == "CLaSH.Sized.Internal.Unsigned.maxBound#" - = case args of - [litTy,kn@(Left (Literal (IntegerLiteral mb)))] - -> let maxB = (2 ^ mb) - 1 - in mkApps unsignedConPrim [litTy,kn,Left (Literal (IntegerLiteral maxB))] - _ -> e - | nm == "CLaSH.Sized.Internal.Signed.toInteger#" || nm == "CLaSH.Sized.Internal.Unsigned.toInteger#" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [collectArgs -> (Prim nm' _,[Right _, Left _, Left (Literal (IntegerLiteral i))])] - | nm' == "CLaSH.Sized.Internal.Signed.fromInteger#" || - nm' == "CLaSH.Sized.Internal.Unsigned.fromInteger#" -> Literal (IntegerLiteral i) - _ -> e - | nm == "CLaSH.Sized.Internal.Signed.eq#" || nm == "CLaSH.Sized.Internal.Unsigned.eq#" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [collectArgs -> (Prim _ _,[Right _, Left _, Left (Literal (IntegerLiteral i))]) ,collectArgs -> (Prim _ _,[Right _, Left _, Left (Literal (IntegerLiteral j))])] -> - let (_,tyView -> TyConApp boolTcNm []) = splitFunForallTy ty - (Just boolTc) = HashMap.lookup boolTcNm tcm - [falseDc,trueDc] = tyConDataCons boolTc - retDc = if i == j then trueDc else falseDc - in Data retDc - _ -> e - | nm == "GHC.TypeLits.natVal" - = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [Literal (IntegerLiteral i), _] -> Literal (IntegerLiteral i) - _ -> e - | nm == "CLaSH.Promoted.Nat.SNat" - = case (map collectArgs . Either.lefts) args of - [(Literal (IntegerLiteral _),[]), (Data _,_)] -> mkApps snatCon args - _ -> e - | isSubj && nm == "CLaSH.Sized.Vector.replicate" - = let ty' = runFreshM (termType tcm e) - in case tyView ty' of - (TyConApp vecTcNm [LitTy (NumTy len),argTy]) -> - let (Just vecTc) = HashMap.lookup vecTcNm tcm - [nilCon,consCon] = tyConDataCons vecTc - in mkVec nilCon consCon argTy len (replicate len (last $ Either.lefts args)) - _ -> e - | isSubj && nm == "CLaSH.Sized.Vector.maxIndex" - = case Either.rights args of - [LitTy (NumTy n), _] -> - let ty' = runFreshM (termType tcm e) - (TyConApp intTcNm _) = tyView ty' - (Just intTc) = HashMap.lookup intTcNm tcm - [intCon] = tyConDataCons intTc - in mkApps (Data intCon) [Left (Literal (IntegerLiteral (toInteger (n - 1))))] - _ -> e - | isSubj && nm == "CLaSH.Sized.Vector.length" - = case Either.rights args of - [LitTy (NumTy n), _] -> - let ty' = runFreshM (termType tcm e) - (TyConApp intTcNm _) = tyView ty' +reduceConstant tcm isSubj e@(collectArgs -> (Prim nm ty, args)) = case nm of + "GHC.Prim.eqChar#" | Just (i,j) <- charLiterals tcm isSubj args + -> boolToIntLiteral (i == j) + + "GHC.Prim.neChar#" | Just (i,j) <- charLiterals tcm isSubj args + -> boolToIntLiteral (i /= j) + + "GHC.Prim.+#" | Just (i,j) <- intLiterals tcm isSubj args + -> integerToIntLiteral (i+j) + + "GHC.Prim.-#" | Just (i,j) <- intLiterals tcm isSubj args + -> integerToIntLiteral (i-j) + + "GHC.Prim.*#" | Just (i,j) <- intLiterals tcm isSubj args + -> integerToIntLiteral (i*j) + + "GHC.Prim.quotInt#" | Just (i,j) <- intLiterals tcm isSubj args + -> integerToIntLiteral (i `quot` j) + + "GHC.Prim.remInt#" | Just (i,j) <- intLiterals tcm isSubj args + -> integerToIntLiteral (i `rem` j) + + "GHC.Prim.quotRemInt#" | Just (i,j) <- intLiterals tcm isSubj args + -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty + (Just tupTc) = HashMap.lookup tupTcNm tcm + [tupDc] = tyConDataCons tupTc + (q,r) = quotRem i j + ret = mkApps (Data tupDc) (map Right tyArgs ++ + [Left (integerToIntLiteral q), Left (integerToIntLiteral r)]) + in ret + + "GHC.Prim.negateInt#" + | [Literal (IntLiteral i)] <- reduceTerms tcm isSubj args + -> integerToIntLiteral (negate i) + + "GHC.Prim.>#" | Just (i,j) <- intLiterals tcm isSubj args + -> boolToIntLiteral (i > j) + + "GHC.Prim.>=#" | Just (i,j) <- intLiterals tcm isSubj args + -> boolToIntLiteral (i >= j) + + "GHC.Prim.==#" | Just (i,j) <- intLiterals tcm isSubj args + -> boolToIntLiteral (i == j) + + "GHC.Prim./=#" | Just (i,j) <- intLiterals tcm isSubj args + -> boolToIntLiteral (i /= j) + + "GHC.Prim.<#" | Just (i,j) <- intLiterals tcm isSubj args + -> boolToIntLiteral (i < j) + + "GHC.Prim.<=#" | Just (i,j) <- intLiterals tcm isSubj args + -> boolToIntLiteral (i <= j) + + "GHC.Prim.eqWord#" | Just (i,j) <- wordLiterals tcm isSubj args + -> boolToIntLiteral (i == j) + + "GHC.Prim.neWord#" | Just (i,j) <- wordLiterals tcm isSubj args + -> boolToIntLiteral (i /= j) + + "GHC.Prim.tagToEnum#" + | [Right (ConstTy (TyCon tcN)), Left (Literal (IntLiteral i))] <- + map (Bifunctor.bimap (reduceConstant tcm isSubj) id) args + -> let dc = do { tc <- HashMap.lookup tcN tcm + ; let dcs = tyConDataCons tc + ; List.find ((== (i+1)) . toInteger . dcTag) dcs + } + in maybe e Data dc + + "GHC.Integer.Type.integerToInt" + | [Literal (IntegerLiteral i)] <- reduceTerms tcm isSubj args + -> integerToIntLiteral i + + "GHC.Integer.Type.plusInteger" | Just (i,j) <- integerLiterals tcm isSubj args + -> integerToIntegerLiteral (i+j) + + "GHC.Integer.Type.minusInteger" | Just (i,j) <- integerLiterals tcm isSubj args + -> integerToIntegerLiteral (i-j) + + "GHC.Integer.Type.timesInteger" | Just (i,j) <- integerLiterals tcm isSubj args + -> integerToIntegerLiteral (i*j) + + "GHC.Integer.Type.negateInteger#" + | [Literal (IntegerLiteral i)] <- reduceTerms tcm isSubj args + -> integerToIntegerLiteral (negate i) + + "GHC.Integer.Type.divInteger" | Just (i,j) <- integerLiterals tcm isSubj args + -> integerToIntegerLiteral (i `div` j) + + "GHC.Integer.Type.modInteger" | Just (i,j) <- integerLiterals tcm isSubj args + -> integerToIntegerLiteral (i `mod` j) + + "GHC.Integer.Type.quotInteger" | Just (i,j) <- integerLiterals tcm isSubj args + -> integerToIntegerLiteral (i `quot` j) + + "GHC.Integer.Type.remInteger" | Just (i,j) <- integerLiterals tcm isSubj args + -> integerToIntegerLiteral (i `rem` j) + + "GHC.Integer.Type.gtInteger" | Just (i,j) <- integerLiterals tcm isSubj args + -> boolToBoolLiteral tcm ty (i > j) + + "GHC.Integer.Type.geInteger" | Just (i,j) <- integerLiterals tcm isSubj args + -> boolToBoolLiteral tcm ty (i >= j) + + "GHC.Integer.Type.eqInteger" | Just (i,j) <- integerLiterals tcm isSubj args + -> boolToBoolLiteral tcm ty (i == j) + + "GHC.Integer.Type.neqInteger" | Just (i,j) <- integerLiterals tcm isSubj args + -> boolToBoolLiteral tcm ty (i /= j) + + "GHC.Integer.Type.ltInteger" | Just (i,j) <- integerLiterals tcm isSubj args + -> boolToBoolLiteral tcm ty (i < j) + + "GHC.Integer.Type.leInteger" | Just (i,j) <- integerLiterals tcm isSubj args + -> boolToBoolLiteral tcm ty (i <= j) + + "GHC.Integer.Type.gtInteger#" | Just (i,j) <- integerLiterals tcm isSubj args + -> boolToIntLiteral (i > j) + + "GHC.Integer.Type.geInteger#" | Just (i,j) <- integerLiterals tcm isSubj args + -> boolToIntLiteral (i >= j) + + "GHC.Integer.Type.eqInteger#" | Just (i,j) <- integerLiterals tcm isSubj args + -> boolToIntLiteral (i == j) + + "GHC.Integer.Type.neqInteger#" | Just (i,j) <- integerLiterals tcm isSubj args + -> boolToIntLiteral (i /= j) + + "GHC.Integer.Type.ltInteger#" | Just (i,j) <- integerLiterals tcm isSubj args + -> boolToIntLiteral (i < j) + + "GHC.Integer.Type.leInteger#" | Just (i,j) <- integerLiterals tcm isSubj args + -> boolToIntLiteral (i <= j) + + "GHC.Integer.Type.shiftRInteger" + | [Literal (IntegerLiteral i), Literal (IntLiteral j)] <- reduceTerms tcm isSubj args + -> integerToIntegerLiteral (i `shiftR` fromInteger j) + + "GHC.Integer.Type.shiftLInteger" + | [Literal (IntegerLiteral i), Literal (IntLiteral j)] <- reduceTerms tcm isSubj args + -> integerToIntegerLiteral (i `shiftL` fromInteger j) + + "GHC.TypeLits.natVal" + | [Literal (IntegerLiteral i), _] <- reduceTerms tcm isSubj args + -> integerToIntegerLiteral i + + "GHC.Types.I#" + | isSubj + , [Literal (IntLiteral i)] <- reduceTerms tcm isSubj args + -> let (_,tyView -> TyConApp intTcNm []) = splitFunForallTy ty (Just intTc) = HashMap.lookup intTcNm tcm - [intCon] = tyConDataCons intTc - in mkApps (Data intCon) [Left (Literal (IntegerLiteral (toInteger n)))] - _ -> e + [intDc] = tyConDataCons intTc + in mkApps (Data intDc) [Left (Literal (IntLiteral i))] + "CLaSH.Sized.Internal.BitVector.eq#" | Just (i,j) <- bitVectorLiterals tcm isSubj args + -> boolToBoolLiteral tcm ty (i == j) + + "CLaSH.Sized.Internal.BitVector.neq#" | Just (i,j) <- bitVectorLiterals tcm isSubj args + -> boolToBoolLiteral tcm ty (i /= j) + + "CLaSH.Sized.Internal.Index.eq#" | Just (i,j) <- indexLiterals tcm isSubj args + -> boolToBoolLiteral tcm ty (i == j) + + "CLaSH.Sized.Internal.Index.neq#" | Just (i,j) <- indexLiterals tcm isSubj args + -> boolToBoolLiteral tcm ty (i /= j) + + "CLaSH.Sized.Internal.Signed.eq#" | Just (i,j) <- signedLiterals tcm isSubj args + -> boolToBoolLiteral tcm ty (i == j) + + "CLaSH.Sized.Internal.Signed.neq#" | Just (i,j) <- signedLiterals tcm isSubj args + -> boolToBoolLiteral tcm ty (i /= j) + + "CLaSH.Sized.Internal.Signed.minBound#" + | [litTy,kn@(Left (Literal (IntegerLiteral mb)))] <- args + -> let minB = negate (2 ^ (mb - 1)) + in mkApps signedConPrim [litTy,kn,Left (Literal (IntegerLiteral minB))] + + "CLaSH.Sized.Internal.Signed.maxBound#" + | [litTy,kn@(Left (Literal (IntegerLiteral mb)))] <- args + -> let maxB = (2 ^ (mb - 1)) - 1 + in mkApps signedConPrim [litTy,kn,Left (Literal (IntegerLiteral maxB))] + + "CLaSH.Sized.Internal.Signed.toInteger#" + | [collectArgs -> (Prim nm' _,[Right _, Left _, Left (Literal (IntegerLiteral i))])] <- + (map (reduceConstant tcm isSubj) . Either.lefts) args + , nm' == "CLaSH.Sized.Internal.Signed.fromInteger#" + -> integerToIntegerLiteral i + + "CLaSH.Sized.Internal.Unsigned.eq#" | Just (i,j) <- unsignedLiterals tcm isSubj args + -> boolToBoolLiteral tcm ty (i == j) + + "CLaSH.Sized.Internal.Unsigned.neq#" | Just (i,j) <- unsignedLiterals tcm isSubj args + -> boolToBoolLiteral tcm ty (i /= j) + + "CLaSH.Sized.Internal.Unsigned.minBound#" + | [litTy,kn@(Left (Literal (IntegerLiteral _)))] <- args + -> mkApps unsignedConPrim [litTy,kn,Left (Literal (IntegerLiteral 0))] + + "CLaSH.Sized.Internal.Unsigned.minBound#" + | [litTy,kn@(Left (Literal (IntegerLiteral mb)))] <- args + -> let maxB = (2 ^ mb) - 1 + in mkApps unsignedConPrim [litTy,kn,Left (Literal (IntegerLiteral maxB))] + + "CLaSH.Sized.Internal.Unsigned.toInteger#" + | [collectArgs -> (Prim nm' _,[Right _, Left _, Left (Literal (IntegerLiteral i))])] <- + (map (reduceConstant tcm isSubj) . Either.lefts) args + , nm' == "CLaSH.Sized.Internal.Unsigned.fromInteger#" + -> integerToIntegerLiteral i + + "CLaSH.Promoted.Nat.SNat" + | [(Literal (IntegerLiteral _),[]), (Data _,_)] <- (map collectArgs . Either.lefts) args + -> mkApps snatCon args + + "CLaSH.Sized.Vector.replicate" + | isSubj + , (TyConApp vecTcNm [LitTy (NumTy len),argTy]) <- tyView (runFreshM (termType tcm e)) + -> let (Just vecTc) = HashMap.lookup vecTcNm tcm + [nilCon,consCon] = tyConDataCons vecTc + in mkVec nilCon consCon argTy len (replicate len (last $ Either.lefts args)) + + "CLaSH.Sized.Vector.maxIndex" + | isSubj + , [LitTy (NumTy n), _] <- Either.rights args + -> let ty' = runFreshM (termType tcm e) + (TyConApp intTcNm _) = tyView ty' + (Just intTc) = HashMap.lookup intTcNm tcm + [intCon] = tyConDataCons intTc + in mkApps (Data intCon) [Left (Literal (IntegerLiteral (toInteger (n - 1))))] + + "CLaSH.Sized.Vector.length" + | isSubj + , [LitTy (NumTy n), _] <- Either.rights args + -> let ty' = runFreshM (termType tcm e) + (TyConApp intTcNm _) = tyView ty' + (Just intTc) = HashMap.lookup intTcNm tcm + [intCon] = tyConDataCons intTc + in mkApps (Data intCon) [Left (Literal (IntegerLiteral (toInteger n)))] + + _ -> e + reduceConstant _ _ e = e +reduceTerms :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> [Term] +reduceTerms tcm isSubj = map (reduceConstant tcm isSubj) . Either.lefts + +integerLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer) +integerLiterals tcm isSubj args = case reduceTerms tcm isSubj args of + [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] -> Just (i,j) + _ -> Nothing + +intLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer) +intLiterals tcm isSubj args = case reduceTerms tcm isSubj args of + [Literal (IntLiteral i), Literal (IntLiteral j)] -> Just (i,j) + _ -> Nothing + +wordLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer) +wordLiterals tcm isSubj args = case (map (reduceConstant tcm isSubj) . Either.lefts) args of + [Literal (WordLiteral i), Literal (WordLiteral j)] -> Just (i,j) + _ -> Nothing + +charLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Char,Char) +charLiterals tcm isSubj args = case (map (reduceConstant tcm isSubj) . Either.lefts) args of + [Literal (CharLiteral i), Literal (CharLiteral j)] -> Just (i,j) + _ -> Nothing + +sizedLiterals :: Text -> HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer) +sizedLiterals szCon tcm isSubj args + = case reduceTerms tcm isSubj args of + ([ collectArgs -> (Prim nm _,[Right _, Left _, Left (Literal (IntegerLiteral i))]) + , collectArgs -> (Prim nm' _,[Right _, Left _, Left (Literal (IntegerLiteral j))])]) + | nm == szCon + , nm' == szCon -> Just (i,j) + _ -> Nothing + +bitVectorLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer) +bitVectorLiterals = sizedLiterals "CLaSH.Sized.Internal.BitVector.fromInteger#" + +indexLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer) +indexLiterals = sizedLiterals "CLaSH.Sized.Internal.Index.fromInteger#" + +signedLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer) +signedLiterals = sizedLiterals "CLaSH.Sized.Internal.Signed.fromInteger#" + +unsignedLiterals :: HashMap.HashMap TyConName TyCon -> Bool -> [Either Term Type] -> Maybe (Integer,Integer) +unsignedLiterals = sizedLiterals "CLaSH.Sized.Internal.Unsigned.fromInteger#" + +boolToIntLiteral :: Bool -> Term +boolToIntLiteral b = if b then Literal (IntLiteral 1) else Literal (IntLiteral 0) + +boolToBoolLiteral :: HashMap.HashMap TyConName TyCon -> Type -> Bool -> Term +boolToBoolLiteral tcm ty b = + let (_,tyView -> TyConApp boolTcNm []) = splitFunForallTy ty + (Just boolTc) = HashMap.lookup boolTcNm tcm + [falseDc,trueDc] = tyConDataCons boolTc + retDc = if b then trueDc else falseDc + in Data retDc + +integerToIntLiteral :: Integer -> Term +integerToIntLiteral = Literal . IntLiteral . toInteger . (fromInteger :: Integer -> Int) -- for overflow behaviour + +integerToIntegerLiteral :: Integer -> Term +integerToIntegerLiteral = Literal . IntegerLiteral + signedConPrim :: Term signedConPrim = Prim "CLaSH.Sized.Internal.Signed.fromInteger#" (ForAllTy (bind nTV funTy)) where @@ -269,4 +365,3 @@ nName = string2Name "n" nVar = VarTy typeNatKind nName nTV = TyVar nName (embed typeNatKind) -