clash-ghc 0.6.16 → 0.6.17
raw patch · 4 files changed
+323/−211 lines, 4 filesdep +deepseqdep +timedep ~clash-libdep ~clash-vhdl
Dependencies added: deepseq, time
Dependency ranges changed: clash-lib, clash-vhdl
Files
- CHANGELOG.md +9/−0
- clash-ghc.cabal +6/−4
- src-bin/InteractiveUI.hs +8/−2
- src-ghc/CLaSH/GHC/Evaluator.hs +300/−205
CHANGELOG.md view
@@ -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)
clash-ghc.cabal view
@@ -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
src-bin/InteractiveUI.hs view
@@ -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)
src-ghc/CLaSH/GHC/Evaluator.hs view
@@ -4,7 +4,7 @@ Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# 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)-