clash-lib 0.5.11 → 0.5.12

raw patch · 13 files changed

+371/−48 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• clash-lib.cabal +1/−1
• src/CLaSH/Core/Util.hs +74/−5
• src/CLaSH/Driver.hs +1/−1
• src/CLaSH/Driver/TestbenchGen.hs +1/−1
• src/CLaSH/Driver/TopWrapper.hs +1/−1
• src/CLaSH/Netlist.hs +9/−4
• src/CLaSH/Normalize.hs +2/−2
• src/CLaSH/Normalize/Strategy.hs +5/−4
• src/CLaSH/Normalize/Transformations.hs +242/−16
• src/CLaSH/Normalize/Util.hs +1/−1
• src/CLaSH/Rewrite/Types.hs +1/−1
• src/CLaSH/Rewrite/Util.hs +22/−11

@@ -1,5 +1,16 @@ # Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package +## 0.5.12 *September 14th 2015*+* New features:+  * Completely unroll "definitions" of some higher-order primitives with non-representable argument or result vectors:+    It is now possible to translate e.g. `f xs ys = zipWith ($) (map (+) xs) ys :: Vec 4 Int -> Vec 4 Int -> Vec 4 Int`++* Fixes bugs:+  * `topLet` transformation erroneously not performed in a top-down traversal+  * Specialisation limit unchecked on types and constants+  * Vector of functions cannot be translated [#25](https://github.com/clash-lang/clash-compiler/issues/25 )+  * CLaSH fails to generate VHDL when map is applied [#78](https://github.com/clash-lang/clash-compiler/issues/78)+ ## 0.5.11 *September 7th 2015* * Fixes bugs:   * Clash running out of memory on Simple-ish project [#70](https://github.com/clash-lang/clash-compiler/issues/70)

@@ -1,5 +1,5 @@ Name:                 clash-lib-Version:              0.5.11+Version:              0.5.12 Synopsis:             CAES Language for Synchronous Hardware - As a Library Description:   CλaSH (pronounced ‘clash’) is a functional hardware description language that

@@ -1,21 +1,26 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}  -- | Smart constructor and destructor functions for CoreHW module CLaSH.Core.Util where  import Data.HashMap.Lazy                       (HashMap)-import Unbound.Generics.LocallyNameless        (Fresh, bind, embed, unbind, unembed,+import Unbound.Generics.LocallyNameless        (Fresh, bind, embed, rebind,+                                                string2Name, unbind, unembed,                                                 unrebind, unrec) import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) -import CLaSH.Core.DataCon                      (dcType)+import CLaSH.Core.DataCon                      (DataCon, dcType, dataConInstArgTys) import CLaSH.Core.Literal                      (literalType) import CLaSH.Core.Pretty                       (showDoc)-import CLaSH.Core.Term                         (Pat (..), Term (..), TmName)-import CLaSH.Core.Type                         (Kind, TyName, Type (..), applyTy,+import CLaSH.Core.Term                         (LetBinding, Pat (..), Term (..),+                                                TmName)+import CLaSH.Core.Type                         (Kind, LitTy (..), TyName,+                                                Type (..), applyTy,                                                 isFunTy, isPolyFunCoreTy, mkFunTy,                                                 splitFunTy) import CLaSH.Core.TyCon                        (TyCon, TyConName)+import CLaSH.Core.TysPrim                      (typeNatKind) import CLaSH.Core.Var                          (Id, TyVar, Var (..), varType) import CLaSH.Util @@ -219,3 +224,67 @@ termSize (Case subj _ alts) = let subjSz = termSize subj                                   altSzs = map (termSize . snd . unsafeUnbind) alts                               in  sum (subjSz:altSzs)++-- | Create a vector of supplied elements+mkVec :: DataCon -- ^ The Nil constructor+      -> DataCon -- ^ The Cons (:>) constructor+      -> Type    -- ^ Element type+      -> Int     -- ^ Length of the vector+      -> [Term]  -- ^ Elements to put in the vector+      -> Term+mkVec nilCon consCon resTy = go+  where+    go _ [] = mkApps (Data nilCon) [Right (LitTy (NumTy 0))+                                   ,Right resTy+                                   ,Left  (Prim "_CO_" nilCoTy)+                                   ]++    go n (x:xs) = mkApps (Data consCon) [Right (LitTy (NumTy n))+                                        ,Right resTy+                                        ,Right (LitTy (NumTy (n-1)))+                                        ,Left (Prim "_CO_" (consCoTy n))+                                        ,Left x+                                        ,Left (go (n-1) xs)]++    nilCoTy    = head (dataConInstArgTys nilCon  [(LitTy (NumTy 0)),resTy])+    consCoTy n = head (dataConInstArgTys consCon [(LitTy (NumTy n))+                                                 ,resTy+                                                 ,(LitTy (NumTy (n-1)))])++-- | Create let-bindings with case-statements that select elements out of a+-- vector. Returns both the variables to which element-selections are bound+-- and the let-bindings+extractElems :: DataCon -- ^ The Cons (:>) constructor+             -> Type    -- ^ The element type+             -> Char    -- ^ Char to append to the bound variable names+             -> Int     -- ^ Length of the vector+             -> Term    -- ^ The vector+             -> [(Term,[LetBinding])]+extractElems consCon resTy s maxN = go maxN+  where+    go :: Int -> Term -> [(Term,[LetBinding])]+    go 0 _ = []+    go n e = (elVar+             ,[(Id elBNm (embed resTy) ,embed lhs)+              ,(Id restBNm (embed restTy),embed rhs)+              ]+             ) :+             go (n-1) (Var restTy restBNm)++      where+        elBNm     = string2Name ("el" ++ s:show (maxN-n))+        restBNm   = string2Name ("rest" ++ s:show (maxN-n))+        elVar     = Var resTy elBNm+        pat       = DataPat (embed consCon) (rebind [mTV] [co,el,rest])+        elPatNm   = string2Name "el"+        restPatNm = string2Name "rest"+        lhs       = Case e resTy  [bind pat (Var resTy  elPatNm)]+        rhs       = Case e restTy [bind pat (Var restTy restPatNm)]++        mName = string2Name "m"+        mTV   = TyVar mName (embed typeNatKind)+        tys   = [(LitTy (NumTy n)),resTy,(LitTy (NumTy (n-1)))]+        idTys = dataConInstArgTys consCon tys+        [co,el,rest] = zipWith Id [string2Name "_co_",elPatNm, restPatNm]+                                  (map embed idTys)+        restTy = last $ dataConInstArgTys consCon tys

@@ -42,7 +42,7 @@             -> PrimMap -- ^ Primitive / BlackBox Definitions             -> HashMap TyConName TyCon -- ^ TyCon cache             -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator-            -> (HashMap TyConName TyCon -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction)+            -> (HashMap TyConName TyCon -> Bool -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction)             -> Maybe TopEntity             -> CLaSHOpts -- ^ Debug information level for the normalization process             -> IO ()

@@ -40,7 +40,7 @@              -> PrimMap                      -- ^ Primitives              -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))              -> HashMap TyConName TyCon-             -> (HashMap TyConName TyCon -> Term -> Term)+             -> (HashMap TyConName TyCon -> Bool -> Term -> Term)              -> Int              -> HashMap TmName (Type,Term)   -- ^ Global binders              -> Maybe TmName                 -- ^ Stimuli

@@ -177,7 +177,7 @@         netdecl = NetDecl iName hwty         assigns = zipWith                     (\id_ n -> Assignment id_-                                 (Identifier iName (Just (Indexed (hwty,1,n)))))+                                 (Identifier iName (Just (Indexed (hwty,10,n)))))                     ids                     [0..]     in  (nms',(ports',(netdecl:assigns ++ decls',iName)))

@@ -20,6 +20,7 @@                                                   unrebind)  import           CLaSH.Core.DataCon               (DataCon (..))+import           CLaSH.Core.FreeVars              (typeFreeVars) import           CLaSH.Core.Literal               (Literal (..)) import           CLaSH.Core.Pretty                (showDoc) import           CLaSH.Core.Term                  (Pat (..), Term (..), TmName)@@ -184,10 +185,14 @@   let dstId    = mkBasicId . Text.pack . name2String $ varName bndr       altVarId = mkBasicId . Text.pack $ name2String varTm       modifier = case pat of-        DataPat (Embed dc) ids -> let tms = case unrebind ids of-                                              ([],tms') -> tms'-                                              _         -> error $ $(curLoc) ++ "Not in normal form: Pattern binds existential variables: " ++ showDoc e-                                  in case elemIndex (Id varTm (Embed varTy)) tms of+        DataPat (Embed dc) ids -> let (exts,tms) = unrebind ids+                                      tmsTys     = map (unembed . varType) tms+                                      tmsFVs     = concatMap (Lens.toListOf typeFreeVars) tmsTys+                                      extNms     = map varName exts+                                      tms'       = if any (`elem` tmsFVs) extNms+                                                      then error $ $(curLoc) ++ "Not in normal form: Pattern binds existential variables: " ++ showDoc e+                                                      else tms+                                  in case elemIndex (Id varTm (Embed varTy)) tms' of                                        Nothing -> Nothing                                        Just fI                                         | sHwTy /= vHwTy -> Just (Indexed (sHwTy,dcTag dc - 1,fI))

@@ -51,7 +51,7 @@                  -- ^ Hardcoded Type -> HWType translator                  -> HashMap TyConName TyCon                  -- ^ TyCon cache-                 -> (HashMap TyConName TyCon -> Term -> Term)+                 -> (HashMap TyConName TyCon -> Bool -> Term -> Term)                  -- ^ Hardcoded evaluator (delta-reduction)                  -> NormalizeSession a                  -- ^ NormalizeSession to run@@ -219,7 +219,7 @@   let (toInline,il_used) = unzip il_ct   newExpr <- case toInline of                [] -> return tm-               _  -> rewriteExpr ("bindConstants",(repeatR (topdownR $ (bindConstantVar >-> caseCon >-> reduceConst))) !-> topLet) (showDoc nm, substTms toInline tm)+               _  -> rewriteExpr ("bindConstants",(repeatR (topdownR $ (bindConstantVar >-> caseCon >-> reduceConst))) !-> topdownSucR topLet) (showDoc nm, substTms toInline tm)   return (CBranch (nm,(ty,newExpr)) (newUsed ++ (concat il_used)))  callTreeToList :: [TmName]

@@ -38,10 +38,11 @@                  ]      transBUP :: [(String,NormRewrite)]-    transBUP = [ ("inlineClosed", inlineClosed)-               , ("inlineSmall" , inlineSmall)-               , ("inlineNonRep", inlineNonRep)-               , ("bindNonRep"  , bindNonRep) -- See: [Note] bindNonRep before liftNonRep+    transBUP = [ ("inlineClosed"    , inlineClosed)+               , ("inlineSmall"     , inlineSmall)+               , ("inlineNonRep"    , inlineNonRep)+               , ("bindNonRep"      , bindNonRep) -- See: [Note] bindNonRep before liftNonRep+               , ("reduceNonRepPrim", reduceNonRepPrim)                ]      specRws :: [(String,NormRewrite)]

@@ -1,5 +1,6 @@-{-# LANGUAGE TemplateHaskell  #-}-{-# LANGUAGE ViewPatterns     #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE ViewPatterns      #-}  -- | Transformations of the Normalization process module CLaSH.Normalize.Transformations@@ -25,6 +26,7 @@   , inlineSmall   , simpleCSE   , reduceConst+  , reduceNonRepPrim   ) where @@ -37,23 +39,27 @@ import qualified Data.Maybe                  as Maybe import           Unbound.Generics.LocallyNameless     (Bind, Embed (..), bind, embed,                                               rec, unbind, unembed, unrebind,-                                              unrec, name2String)+                                              unrec, name2String, string2Name,+                                              rebind) import           Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind) -import           CLaSH.Core.DataCon          (DataCon, dcName, dcTag,-                                              dcUnivTyVars)+import           CLaSH.Core.DataCon          (DataCon (..), dataConInstArgTys) import           CLaSH.Core.FreeVars         (termFreeIds, termFreeTyVars,                                               typeFreeVars) import           CLaSH.Core.Pretty           (showDoc) import           CLaSH.Core.Subst            (substTm, substTms, substTyInTm,                                               substTysinTm) import           CLaSH.Core.Term             (LetBinding, Pat (..), Term (..))-import           CLaSH.Core.Type             (TypeView (..), applyFunTy,-                                              applyTy, splitFunTy, typeKind, tyView)-import           CLaSH.Core.Util             (collectArgs, idToVar, isCon,+import           CLaSH.Core.Type             (TypeView (..), Type (..),+                                              LitTy (..), applyFunTy,+                                              applyTy, splitFunTy, typeKind,+                                              tyView, mkTyConApp, mkFunTy)+import           CLaSH.Core.TyCon            (TyConName, tyConDataCons)+import           CLaSH.Core.Util             (collectArgs, extractElems,+                                              idToVar, isCon,                                               isFun, isLet, isPolyFun, isPrim,                                               isVar, mkApps, mkLams, mkTmApps,-                                              termSize,termType)+                                              mkVec, termSize,termType) import           CLaSH.Core.Var              (Id, Var (..)) import           CLaSH.Netlist.Util          (representableType,                                               splitNormalized)@@ -98,7 +104,7 @@   | (Var _ _,  args) <- collectArgs e1   , null $ Lens.toListOf typeFreeVars ty   , (_, []) <- Either.partitionEithers args-  = specializeNorm False ctx e+  = specializeNorm ctx e  typeSpec _ e = return e @@ -113,7 +119,7 @@        localVar <- isLocalVar e2        nonRepE2 <- not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view tcCache <*> pure e2Ty)        if nonRepE2 && not localVar-         then specializeNorm True ctx e+         then specializeNorm ctx e          else return e  nonRepSpec _ e = return e@@ -226,7 +232,7 @@     tcm <- Lens.view tcCache     lvl <- Lens.view dbgLevel     reduceConstant <- Lens.view evaluator-    case reduceConstant tcm subj of+    case reduceConstant tcm True subj of       Literal l -> caseCon ctx (Case (Literal l) ty alts)       subj'@(collectArgs -> (Data _,_)) -> caseCon ctx (Case subj' ty alts)       subj' -> traceIf (lvl > DebugNone) ("Irreducible constant as case subject: " ++ showDoc subj ++ "\nCan be reduced to: " ++ showDoc subj') (caseOneAlt e)@@ -261,8 +267,8 @@     case (untranslatable,arg) of       (True,Letrec b) -> do (binds,body) <- unbind b                             changed (Letrec (bind binds (App appConPrim body)))-      (True,Case {})  -> specializeNorm True ctx e-      (True,Lam _)    -> specializeNorm True ctx e+      (True,Case {})  -> specializeNorm ctx e+      (True,Lam _)    -> specializeNorm ctx e       _               -> return e  nonRepANF _ e = return e@@ -395,7 +401,7 @@   , (_, [])     <- Either.partitionEithers args   , null $ Lens.toListOf termFreeTyVars e2   , isConstant e2-  = specializeNorm False ctx e+  = specializeNorm ctx e  constantSpec _ e = return e @@ -693,9 +699,229 @@   = do     tcm <- Lens.view tcCache     reduceConstant <- Lens.view evaluator-    case reduceConstant tcm e of+    case reduceConstant tcm False e of       e'@(Data _)    -> changed e'       e'@(Literal _) -> changed e'       _              -> return e  reduceConst _ e = return e++-- | Replace primitives by their "definition" if they would lead to let-bindings+-- with a non-representable type when a function is in ANF. This happens for+-- example when CLaSH.Size.Vector.map consumes or produces a vector of+-- non-representable elements.+--+-- Basically what this transformation does is replace a primitive the completely+-- unrolled recursive definition that it represents. e.g.+--+-- > zipWith ($) (xs :: Vec 2 (Int -> Int)) (ys :: Vec 2 Int)+--+-- is replaced by:+--+-- > let (x0  :: (Int -> Int))       = case xs  of (:>) _ x xr -> x+-- >     (xr0 :: Vec 1 (Int -> Int)) = case xs  of (:>) _ x xr -> xr+-- >     (x1  :: (Int -> Int)(       = case xr0 of (:>) _ x xr -> x+-- >     (y0  :: Int)                = case ys  of (:>) _ y yr -> y+-- >     (yr0 :: Vec 1 Int)          = case ys  of (:>) _ y yr -> xr+-- >     (y1  :: Int                 = case yr0 of (:>) _ y yr -> y+-- > in  (($) x0 y0 :> ($) x1 y1 :> Nil)+--+-- Currently, it only handles the following functions:+--+-- * CLaSH.Sized.Vector.map+-- * CLaSH.Sized.Vector.zipWith+-- * CLaSH.Sized.Vector.traverse#+reduceNonRepPrim :: NormRewrite+reduceNonRepPrim _ e@(App _ _)+  | (Prim f _, args) <- collectArgs e+  = case f of+      "CLaSH.Sized.Vector.zipWith" | length args == 7 -> do+        let [lhsElTy,rhsElty,resElTy,nTy] = Either.rights args+        case nTy of+          (LitTy (NumTy n)) -> do+            untranslatableTys <- mapM isUntranslatableType [lhsElTy,rhsElty,resElTy]+            if or untranslatableTys+               then let [fun,lhsArg,rhsArg] = Either.lefts args+                    in  reduceZipWith n lhsElTy rhsElty resElTy fun lhsArg rhsArg+               else return e+          _ -> return e+      "CLaSH.Sized.Vector.map" | length args == 5 -> do+        let [argElTy,resElTy,nTy] = Either.rights args+        case nTy of+          (LitTy (NumTy n)) -> do+            untranslatableTys <- mapM isUntranslatableType [argElTy,resElTy]+            if or untranslatableTys+               then let [fun,arg] = Either.lefts args+                    in  reduceMap n argElTy resElTy fun arg+               else return e+          _ -> return e+      "CLaSH.Sized.Vector.traverse#" | length args == 7 ->+        let [aTy,fTy,bTy,nTy] = Either.rights args+        in  case nTy of+          (LitTy (NumTy n)) ->+            let [dict,fun,arg] = Either.lefts args+            in  reduceTraverse n aTy fTy bTy dict fun arg+          _ -> return e+      _ -> return e++reduceNonRepPrim _ e = return e++-- | Replace an application of @CLaSH.Sized.Vector.zipWith@ primitive on vectors+-- of a known length @n@, by the fully unrolled recursive "definition" of of+-- @CLaSH.Sized.Vector.zipWith@+reduceZipWith :: Int  -- ^ Length of the vector(s)+              -> Type -- ^ Type of the lhs of the function+              -> Type -- ^ Type of the rhs of the function+              -> Type -- ^ Type of the result of the function+              -> Term -- ^ The zipWith'd functions+              -> Term -- ^ The 1st vector argument+              -> Term -- ^ The 2nd vector argument+              -> NormalizeSession Term+reduceZipWith n lhsElTy rhsElTy resElTy fun lhsArg rhsArg = do+  tcm <- Lens.view tcCache+  (TyConApp vecTcNm _) <- tyView <$> termType tcm lhsArg+  let (Just vecTc)     = HashMap.lookup vecTcNm tcm+      [nilCon,consCon] = tyConDataCons vecTc+      (varsL,elemsL)   = second concat . unzip $ extractElems consCon lhsElTy 'L' n lhsArg+      (varsR,elemsR)   = second concat . unzip $ extractElems consCon rhsElTy 'R' n rhsArg+      funApps          = zipWith (\l r -> mkApps fun [Left l,Left r]) varsL varsR+      lbody            = mkVec nilCon consCon resElTy n funApps+      lb               = Letrec (bind (rec (init elemsL ++ init elemsR)) lbody)+  changed lb++-- | Replace an application of @CLaSH.Sized.Vector.map@ primitive on vectors+-- of a known length @n@, by the fully unrolled recursive "definition" of of+-- @CLaSH.Sized.Vector.map@+reduceMap :: Int  -- ^ Length of the vector+          -> Type -- ^ Argument type of the function+          -> Type -- ^ Result type of the function+          -> Term -- ^ The map'd function+          -> Term -- ^ The map'd over vector+          -> NormalizeSession Term+reduceMap n argElTy resElTy fun arg = do+  tcm <- Lens.view tcCache+  (TyConApp vecTcNm _) <- tyView <$> termType tcm arg+  let (Just vecTc)     = HashMap.lookup vecTcNm tcm+      [nilCon,consCon] = tyConDataCons vecTc+      (vars,elems)     = second concat . unzip $ extractElems consCon argElTy 'A' n arg+      funApps          = map (fun `App`) vars+      lbody            = mkVec nilCon consCon resElTy n funApps+      lb               = Letrec (bind (rec (init elems)) lbody)+  changed lb++-- | Replace an application of @CLaSH.Sized.Vector.traverse#@ primitive on+-- vectors of a known length @n@, by the fully unrolled recursive "definition"+-- of @CLaSH.Sized.Vector.map@+reduceTraverse :: Int  -- ^ Length of the vector+               -> Type -- ^ Element type of the argument vector+               -> Type -- ^ The type of the applicative+               -> Type -- ^ Element type of the result vector+               -> Term -- ^ The @Applicative@ dictionary+               -> Term -- ^ The function to traverse with+               -> Term -- ^ The argument vector+               -> NormalizeSession Term+reduceTraverse n aTy fTy bTy dict fun arg = do+  tcm <- Lens.view tcCache+  (TyConApp vecTcNm    _) <- tyView <$> termType tcm arg+  (TyConApp apDictTcNm _) <- tyView <$> termType tcm dict+  let (Just apDictTc)    = HashMap.lookup apDictTcNm tcm+      [apDictCon]        = tyConDataCons apDictTc+      apDictIdTys        = dataConInstArgTys apDictCon [fTy]+      apDictIds          = zipWith Id (map string2Name ["functorDict"+                                                       ,"pure"+                                                       ,"ap"+                                                       ,"apConstL"+                                                       ,"apConstR"])+                                      (map embed apDictIdTys)++      (TyConApp funcDictTcNm _) = tyView (head apDictIdTys)+      (Just funcDictTc) = HashMap.lookup funcDictTcNm tcm+      [funcDictCon] = tyConDataCons funcDictTc+      funcDictIdTys = dataConInstArgTys funcDictCon [fTy]+      funcDicIds    = zipWith Id (map string2Name ["fmap","fmapConst"])+                                 (map embed funcDictIdTys)++      apPat    = DataPat (embed apDictCon) (rebind [] apDictIds)+      fnPat    = DataPat (embed funcDictCon) (rebind [] funcDicIds)++      -- Extract the 'pure' function from the Applicative dictionary+      pureTy = apDictIdTys!!1+      pureTm = Case dict pureTy [bind apPat (Var pureTy (string2Name "pure"))]++      -- Extract the '<*>' function from the Applicative dictionary+      apTy   = apDictIdTys!!2+      apTm   = Case dict apTy [bind apPat (Var apTy (string2Name "ap"))]++      -- Extract the Functor dictionary from the Applicative dictionary+      funcTy = (head apDictIdTys)+      funcTm = Case dict funcTy+                         [bind apPat (Var funcTy (string2Name "functorDict"))]++      -- Extract the 'fmap' function from the Functor dictionary+      fmapTy = (head funcDictIdTys)+      fmapTm = Case (Var funcTy (string2Name "functorDict")) fmapTy+                    [bind fnPat (Var fmapTy (string2Name "fmap"))]++      (Just vecTc)     = HashMap.lookup vecTcNm tcm+      [nilCon,consCon] = tyConDataCons vecTc+      (vars,elems)     = second concat . unzip+                                       $ extractElems consCon aTy 'T' n arg++      funApps = map (fun `App`) vars++      lbody   = mkTravVec vecTcNm nilCon consCon (idToVar (apDictIds!!1))+                                                 (idToVar (apDictIds!!2))+                                                 (idToVar (funcDicIds!!0))+                                                 bTy n funApps++      lb      = Letrec (bind (rec ([((apDictIds!!0),embed funcTm)+                                   ,((apDictIds!!1),embed pureTm)+                                   ,((apDictIds!!2),embed apTm)+                                   ,((funcDicIds!!0),embed fmapTm)+                                   ] ++ init elems)) lbody)+  changed lb++-- | Create the traversable vector+--+-- e.g. for a length '2' input vector, we get+--+-- > (:>) <$> x0 <*> ((:>) <$> x1 <*> pure Nil)+mkTravVec :: TyConName -- ^ Vec tcon+          -> DataCon   -- ^ Nil con+          -> DataCon   -- ^ Cons con+          -> Term      -- ^ 'pure' term+          -> Term      -- ^ '<*>' term+          -> Term      -- ^ 'fmap' term+          -> Type      -- ^ 'b' ty+          -> Int       -- ^ Length of the vector+          -> [Term]    -- ^ Elements of the vector+          -> Term+mkTravVec vecTc nilCon consCon pureTm apTm fmapTm bTy = go+  where+    go :: Int -> [Term] -> Term+    go _ [] = mkApps pureTm [Right (mkTyConApp vecTc [LitTy (NumTy 0),bTy])+                            ,Left  (mkApps (Data nilCon)+                                           [Right (LitTy (NumTy 0))+                                           ,Right bTy+                                           ,Left  (Prim "_CO_" nilCoTy)])]++    go n (x:xs) = mkApps apTm+      [Right (mkTyConApp vecTc [LitTy (NumTy (n-1)),bTy])+      ,Right (mkTyConApp vecTc [LitTy (NumTy n),bTy])+      ,Left (mkApps fmapTm [Right bTy+                           ,Right (mkFunTy (mkTyConApp vecTc [LitTy (NumTy (n-1)),bTy])+                                           (mkTyConApp vecTc [LitTy (NumTy n),bTy]))+                           ,Left  (mkApps (Data consCon)+                                          [Right (LitTy (NumTy n))+                                          ,Right bTy+                                          ,Right (LitTy (NumTy (n-1)))+                                          ,Left  (Prim "_CO_" (consCoTy n))+                                          ])+                           ,Left  x])+      ,Left (go (n-1) xs)]++    nilCoTy = head (dataConInstArgTys nilCon [(LitTy (NumTy 0)),bTy])++    consCoTy n = head (dataConInstArgTys consCon [(LitTy (NumTy n))+                                                 ,bTy+                                                 ,(LitTy (NumTy (n-1)))])

@@ -47,7 +47,7 @@                      (HashMap.singleton f 1)  -- | Specialize under the Normalization Monad-specializeNorm :: Bool -> NormRewrite+specializeNorm :: NormRewrite specializeNorm = specialise specialisationCache specialisationHistory specialisationLimit  -- | Determine if a term is closed

@@ -77,7 +77,7 @@   -- ^ Hardcode Type -> HWType translator   , _tcCache        :: HashMap TyConName TyCon   -- ^ TyCon cache-  , _evaluator      :: HashMap TyConName TyCon -> Term -> Term+  , _evaluator      :: HashMap TyConName TyCon -> Bool -> Term -> Term   -- ^ Hardcoded evaluator (delta-reduction)}   } 

@@ -405,13 +405,25 @@   $ Lens.use bindings isLocalVar _ = return False +{-# INLINE isUntranslatable #-} -- | Determine if a term cannot be represented in hardware isUntranslatable :: Term                  -> RewriteMonad extra Bool isUntranslatable tm = do   tcm <- Lens.view tcCache-  not <$> (representableType <$> Lens.view typeTranslator <*> pure tcm <*> termType tcm tm)+  not <$> (representableType <$> Lens.view typeTranslator+                             <*> pure tcm+                             <*> termType tcm tm) +{-# INLINE isUntranslatableType #-}+-- | Determine if a type cannot be represented in hardware+isUntranslatableType :: Type+                     -> RewriteMonad extra Bool+isUntranslatableType ty =+  not <$> (representableType <$> Lens.view typeTranslator+                             <*> Lens.view tcCache+                             <*> pure ty)+ -- | Is the Context a Lambda/Term-abstraction context? isLambdaBodyCtx :: CoreContext                 -> Bool@@ -460,24 +472,22 @@ specialise :: Lens' extra (Map.Map (TmName, Int, Either Term Type) (TmName,Type)) -- ^ Lens into previous specialisations            -> Lens' extra (HashMap TmName Int) -- ^ Lens into the specialisation history            -> Lens' extra Int -- ^ Lens into the specialisation limit-           -> Bool            -> Rewrite extra-specialise specMapLbl specHistLbl specLimitLbl doCheck ctx e = case e of-  (TyApp e1 ty) -> specialise' specMapLbl specHistLbl specLimitLbl False ctx e (collectArgs e1) (Right ty)-  (App e1 e2)   -> specialise' specMapLbl specHistLbl specLimitLbl doCheck ctx e (collectArgs e1) (Left  e2)+specialise specMapLbl specHistLbl specLimitLbl ctx e = case e of+  (TyApp e1 ty) -> specialise' specMapLbl specHistLbl specLimitLbl ctx e (collectArgs e1) (Right ty)+  (App e1 e2)   -> specialise' specMapLbl specHistLbl specLimitLbl ctx e (collectArgs e1) (Left  e2)   _             -> return e  -- | Specialise an application on its argument specialise' :: Lens' extra (Map.Map (TmName, Int, Either Term Type) (TmName,Type)) -- ^ Lens into previous specialisations             -> Lens' extra (HashMap TmName Int) -- ^ Lens into specialisation history             -> Lens' extra Int -- ^ Lens into the specialisation limit-            -> Bool -- ^ Perform specialisation limit check             -> [CoreContext] -- Transformation context             -> Term -- ^ Original term             -> (Term, [Either Term Type]) -- ^ Function part of the term, split into root and applied arguments             -> Either Term Type -- ^ Argument to specialize on             -> RewriteMonad extra Term-specialise' specMapLbl specHistLbl specLimitLbl doCheck ctx e (Var _ f, args) specArg = do+specialise' specMapLbl specHistLbl specLimitLbl ctx e (Var _ f, args) specArg = do   lvl <- Lens.view dbgLevel   -- Create binders and variable references for free variables in 'specArg'   (specBndrs,specVars) <- specArgBndrsAndVars ctx specArg@@ -499,7 +509,7 @@           -- Determine if we see a sequence of specialisations on a growing argument           specHistM <- HML.lookup f <$> Lens.use (extra.specHistLbl)           specLim   <- Lens.use (extra . specLimitLbl)-          if doCheck && maybe False (> specLim) specHistM+          if maybe False (> specLim) specHistM             then fail $ unlines [ "Hit specialisation limit " ++ show specLim ++ " on function `" ++ showDoc f ++ "'.\n"                                 , "The function `" ++ showDoc f ++ "' is most likely recursive, and looks like it is being indefinitely specialized on a growing argument.\n"                                 , "Body of `" ++ showDoc f ++ "':\n" ++ showDoc bodyTm ++ "\n"@@ -522,19 +532,20 @@               newf `deepseq` changed newExpr         Nothing -> return e -specialise' _ _ _ _ ctx _ (appE,args) (Left specArg) = do+specialise' _ _ _ ctx _ (appE,args) (Left specArg) = do   -- Create binders and variable references for free variables in 'specArg'   (specBndrs,specVars) <- specArgBndrsAndVars ctx (Left specArg)   -- Create specialized function   let newBody = mkAbstraction specArg specBndrs-  newf <- mkFunction (string2Name "specF") newBody+  cf   <- Lens.use curFun+  newf <- mkFunction (string2Name (name2String cf ++ "_" ++ "specF")) newBody   -- Create specialized argument   let newArg  = Left $ mkApps ((uncurry . flip) Var newf) specVars   -- Use specialized argument   let newExpr = mkApps appE (args ++ [newArg])   changed newExpr -specialise' _ _ _ _ _ e _ _ = return e+specialise' _ _ _ _ e _ _ = return e  -- | Create binders and variable references for free variables in 'specArg' specArgBndrsAndVars :: [CoreContext]