clash 0.1.0.2 → 0.1.1.0
raw patch · 18 files changed
+1443/−476 lines, 18 filesdep ~vhdl
Dependency ranges changed: vhdl
Files
- CLasH/HardwareTypes.hs +15/−25
- CLasH/Normalize.hs +536/−38
- CLasH/Normalize/NormalizeTools.hs +86/−9
- CLasH/Normalize/NormalizeTypes.hs +28/−3
- CLasH/Translator.hs +3/−2
- CLasH/Translator/TranslatorTypes.hs +9/−1
- CLasH/Utils/Core/CoreTools.hs +50/−19
- CLasH/Utils/Pretty.hs +78/−1
- CLasH/VHDL/Constants.hs +16/−7
- CLasH/VHDL/Generate.hs +300/−192
- CLasH/VHDL/Testbench.hs +2/−2
- CLasH/VHDL/VHDLTools.hs +229/−98
- Data/Param/Index.hs +17/−17
- Data/Param/Integer.hs +7/−1
- Data/Param/Signed.hs +27/−23
- Data/Param/Unsigned.hs +27/−23
- Data/Param/Vector.hs +11/−13
- clash.cabal +2/−2
CLasH/HardwareTypes.hs view
@@ -1,16 +1,17 @@-{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, FlexibleContexts, TypeFamilies, TypeOperators #-}+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} module CLasH.HardwareTypes ( module Types+ , module Data.Param.Integer , module Data.Param.Vector , module Data.Param.Index , module Data.Param.Signed , module Data.Param.Unsigned , module Prelude+ , module Data.Bits+ , module Language.Haskell.TH.Lift , Bit(..) , State(..)- , resizeInt- , resizeWord , hwand , hwor , hwxor@@ -21,31 +22,23 @@ ) where import qualified Prelude as P-import Prelude hiding (- null, length, head, tail, last, init, take, drop, (++), map, foldl, foldr,- zipWith, zip, unzip, concat, reverse, iterate )+import Prelude (Bool(..),Num(..),Eq(..),Ord(..),snd,fst,otherwise,(&&),(||),not) import Types+import Data.Param.Integer (HWBits(..)) import Data.Param.Vector import Data.Param.Index-import qualified Data.Param.Signed as Signed-import Data.Param.Signed hiding (resize)-import qualified Data.Param.Unsigned as Unsigned-import Data.Param.Unsigned hiding (resize) +import Data.Param.Signed+import Data.Param.Unsigned +import Data.Bits hiding (shiftL,shiftR) import Language.Haskell.TH.Lift import Data.Typeable newtype State s = State s deriving (P.Show) -resizeInt :: (NaturalT nT, NaturalT nT') => Signed nT -> Signed nT'-resizeInt = Signed.resize--resizeWord :: (NaturalT nT, NaturalT nT') => Unsigned nT -> Unsigned nT'-resizeWord = Unsigned.resize- -- The plain Bit type data Bit = High | Low- deriving (P.Show, P.Eq, P.Read, Typeable)+ deriving (P.Show, Eq, P.Read, Typeable) deriveLift ''Bit @@ -68,20 +61,17 @@ hwnot High = Low hwnot Low = High -type RAM s a = Vector (s :+: D1) a--type MemState s a = State (RAM s a)+type RAM s a = Vector s a+type MemState s a = State (RAM s a) blockRAM :: - (NaturalT s- ,PositiveT (s :+: D1)- ,((s :+: D1) :>: s) ~ True ) =>- (MemState s a) -> + PositiveT s =>+ MemState s a -> a -> Index s -> Index s -> Bool -> - ((MemState s a), a )+ (MemState s a, a ) blockRAM (State mem) data_in rdaddr wraddr wrenable = ((State mem'), data_out) where
CLasH/Normalize.hs view
@@ -3,7 +3,7 @@ -- top level function "normalize", and defines the actual transformation passes that -- are performed. ---module CLasH.Normalize (getNormalized, normalizeExpr, splitNormalized) where+module CLasH.Normalize (getNormalized, normalizeExpr, splitNormalized, transforms) where -- Standard modules import Debug.Trace@@ -158,20 +158,20 @@ -- By not inlining any other reference, we also prevent looping problems -- with funextract and inlinedict. inlinetoplevel :: Transform-inlinetoplevel (LetBinding:_) expr | not (is_fun expr) =+inlinetoplevel c expr | not (null c) && is_letbinding_ctx (head c) && not (is_fun expr) = case collectArgs expr of- (Var f, args) -> do- body_maybe <- needsInline f- case body_maybe of- Just body -> do- -- Regenerate all uniques in the to-be-inlined expression- body_uniqued <- Trans.lift $ genUniques body- -- And replace the variable reference with the unique'd body.- change (mkApps body_uniqued args)- -- No need to inline- Nothing -> return expr- -- This is not an application of a binder, leave it unchanged.- _ -> return expr+ (Var f, args) -> do+ body_maybe <- needsInline f+ case body_maybe of+ Just body -> do+ -- Regenerate all uniques in the to-be-inlined expression+ body_uniqued <- Trans.lift $ genUniques body+ -- And replace the variable reference with the unique'd body.+ change (mkApps body_uniqued args)+ -- No need to inline+ Nothing -> return expr+ -- This is not an application of a binder, leave it unchanged.+ _ -> return expr -- Leave all other expressions unchanged inlinetoplevel c expr = return expr@@ -216,12 +216,12 @@ -- body consisting of a bunch of nested lambdas containing a -- non-function value (e.g., a complete application). eta :: Transform-eta (AppFirst:_) expr = return expr+eta c expr | not (null c) && is_appfirst_ctx (head c) = return expr -- Also don't apply to arguments, since this can cause loops with -- funextract. This isn't the proper solution, but due to an -- implementation bug in notappargs, this is how it used to work so far.-eta (AppSecond:_) expr = return expr-eta c expr | is_fun expr && not (is_lam expr) = do+ | not (null c) && is_appsecond_ctx (head c) = return expr+ | is_fun expr && not (is_lam expr) = do let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr id <- Trans.lift $ mkInternalVar "param" arg_ty change (Lam id (App expr (Var id)))@@ -296,7 +296,7 @@ -- Extract the return value from the body of the top level lambdas (of -- which ther could be zero), unless it is a let expression (in which -- case the next clause applies).-retvalsimpl c expr | all (== LambdaBody) c && not (is_lam expr) && not (is_let expr) = do+retvalsimpl c expr | all is_lambdabody_ctx c && not (is_lam expr) && not (is_let expr) = do local_var <- Trans.lift $ is_local_var expr repr <- isRepr expr if not local_var && repr@@ -308,7 +308,7 @@ -- Extract the return value from the body of a let expression, which is -- itself the body of the top level lambdas (of which there could be -- zero).-retvalsimpl c expr@(Let (Rec binds) body) | all (== LambdaBody) c = do+retvalsimpl c expr@(Let (Rec binds) body) | all is_lambdabody_ctx c = do -- Don't extract values that are already a local variable, to prevent -- loops with ourselves. local_var <- Trans.lift $ is_local_var body@@ -489,7 +489,25 @@ -- Wilden the binders of one alt, producing a list of bindings as a -- sideeffect. doalt :: CoreAlt -> TransformMonad ([(CoreBndr, CoreExpr)], CoreAlt)- doalt (con, bndrs, expr) = do+ doalt (LitAlt _, _, _) = error $ "Don't know how to handle LitAlt in case expression: " ++ pprString expr+ doalt alt@(DEFAULT, [], expr) = do+ local_var <- Trans.lift $ is_local_var expr+ repr <- isRepr expr+ -- Extract any expressions that is not a local var already and is + -- representable (to prevent loops with inlinenonrep).+ (exprbinding_maybe, expr') <- if (not local_var) && repr+ then do+ id <- Trans.lift $ mkBinderFor expr "caseval"+ -- We don't flag a change here, since casevalsimpl will do that above+ -- based on Just we return here.+ return (Just (id, expr), Var id)+ else+ -- Don't simplify anything else+ return (Nothing, expr)+ let newalt = (DEFAULT, [], expr')+ let bindings = Maybe.catMaybes [exprbinding_maybe]+ return (bindings, newalt)+ doalt (DataAlt dc, bndrs, expr) = do -- Make each binder wild, if possible bndrs_res <- Monad.zipWithM dobndr bndrs [0..] let (newbndrs, bindings_maybe) = unzip bndrs_res@@ -499,7 +517,7 @@ let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) expr (exprbinding_maybe, expr') <- doexpr expr uses_bndrs -- Create a new alternative- let newalt = (con, newbndrs, expr')+ let newalt = (DataAlt dc, newbndrs, expr') let bindings = Maybe.catMaybes (bindings_maybe ++ [exprbinding_maybe]) return (bindings, newalt) where@@ -521,7 +539,8 @@ -- inlinenonrep). if (not wild) && repr then do- caseexpr <- Trans.lift $ mkSelCase scrut i+ let dc_i = datacon_index (CoreUtils.exprType scrut) dc+ caseexpr <- Trans.lift $ mkSelCase scrut dc_i i -- Create a new binder that will actually capture a value in this -- case statement, and return it. return (wildbndrs!!i, Just (b, caseexpr))@@ -793,7 +812,7 @@ res_bndr <- Trans.lift $ mkBinderFor newapp "res" -- Create extractor case expressions to extract each of the -- free variables from the tuple.- sel_cases <- Trans.lift $ mapM (mkSelCase (Var res_bndr)) [0..n_free_vars-1]+ sel_cases <- Trans.lift $ mapM (mkSelCase (Var res_bndr) 0) [0..n_free_vars-1] -- Bind the res_bndr to the result of the new application -- and each of the free variables to the corresponding@@ -945,13 +964,438 @@ letmerge c expr = return expr -} +----------------------------------------------------------------+-- Arrow transformations+----------------------------------------------------------------++extractArrowExpression :: CoreBndr -> TransformMonad CoreExpr+extractArrowExpression bndr = do+ fExpr <- Trans.lift $ getNormalized False bndr+ arrowsMap <- Trans.lift $ MonadState.get tsArrows+ let transF = Maybe.fromMaybe (error $ "Normalize.extractArrowExpression: could not find real function of: " ++ pprString bndr) $ Map.lookup bndr arrowsMap+ return $ Var transF+ ----------------------------------- End of transformations+-- ArrowHooks (>>>) inlining --------------------------------+-- Arrow expressions usually take on the form of:+--+-- letrec d = (>>>) a b c ....+-- in+-- letrec+-- x = d y z+-- o = d p q+-- ...+--+-- So we want to inline the arrow hooks (>>>) hoping the arrowHooksExtract +-- transformation (which mathes on the operator) will later remove it at every+-- inlined location.+inlineArrowHooks :: Transform+inlineArrowHooks c expr@(Let (Rec [(bndr,val)]) res) | isArrowE expr = inlinebind condition c expr+ where+ condition :: ((CoreBndr, CoreExpr) -> TransformMonad Bool)+ condition (b, e) = do+ return (b == bndr)+ +inlineArrowHooks c expr = return expr +--------------------------------+-- liftS (^^^) extraction+--------------------------------+-- Stateful functions are explicitly lifted to arrows by the programmer using +-- the lifting (^^^) function, e.g. f ^^^ i; where f is of type: +-- a -> b -> (a,c). We replace the lifting function by an application of 'f' +-- to its arguments: f (x::a) (y::b). We also associate the initial state, +-- 'i', to this particular instantiation of f.+-- +-- From: +-- (^^^) (f :: s -> a -> (s,b)) i+-- +-- To: +-- \(s::s) (i::a) -> f i +arrowLiftSExtract :: Transform+arrowLiftSExtract c expr@(App _ _) | isLift (appliedF, alreadyMappedArgs) = do+ -- Collect the lifted function and the initial state+ let (Var liftS) = appliedF+ let [realfun, Var initvalue] = get_val_args (Var.varType liftS) alreadyMappedArgs+ -- TODO: All of this looks/is hacked! Needs rethinking and rewriting+ (realfunBndr, realfunBody) <- case realfun of+ (Var realfunBndr) -> do+ exprMaybe <- Trans.lift $ getGlobalBind realfunBndr+ let body = Maybe.fromMaybe (error $ "Normalize.arrowLiftSExtract: could not find lifted function: " ++ pprString realfun) exprMaybe+ -- Clone the lifted function+ realfun' <- Trans.lift $ mkFunction realfunBndr body+ return (realfun', Var realfun')+ (App appliedFun appliedArgs) -> do+ let (Var appliedFunBndr, _) = collectArgs realfun+ exprMaybe <- Trans.lift $ getGlobalBind appliedFunBndr+ let body = Maybe.fromMaybe (error $ "Normalize.arrowLiftSExtract: could not find lifted function: " ++ pprString realfun) exprMaybe+ realfun' <- Trans.lift $ mkFunction appliedFunBndr body+ return (realfun', App (Var realfun') appliedArgs) + -- Create 2 new Vars that that will be applied to the lifted function+ let [arg1Ty,arg2Ty] = (fst . Type.splitFunTys . CoreUtils.exprType) realfun+ id1 <- Trans.lift $ mkInternalVar "param" arg1Ty+ id2 <- Trans.lift $ mkInternalVar "param" arg2Ty+ -- Associate initial value with the cloned functions+ initbndr_maybe <- Trans.lift $ getGlobalBind initvalue+ initbndr <- case initbndr_maybe of+ (Just a) -> return initvalue+ Nothing -> do+ let body = Var initvalue+ initId <- Trans.lift $ mkBinderFor body ("init" ++ Name.getOccString realfunBndr)+ Trans.lift $ addGlobalBind initId body+ return initId + Trans.lift $ MonadState.modify tsInitStates (Map.insert realfunBndr initbndr)+ -- Return the extracted expression + change (Lam id1 (Lam id2 (App (App realfunBody (Var id1)) (Var id2))))+ where+ (appliedF, alreadyMappedArgs) = collectArgs expr +-- Leave all other expressions unchanged +arrowLiftSExtract c e = return e +----------------------------------+-- implicit lift (arr) extraction+----------------------------------+-- Combinational functions are implicitly lifted to arrows by GHC using the +-- the 'arr' function, e.g. arr f; where f is of type: a -> b. We replace the +-- lifting function by an application of 'f' to its argument: f (x::a). +-- +-- From: +-- arr (f :: a -> b)+-- +-- To: +-- \() (x::a) -> ((), f x)+arrowLiftExtract :: Transform+arrowLiftExtract c expr@(App _ _) | isArrLift (appliedF, alreadyMappedArgs) = do+ -- Collect the lifted function and the initial state+ let (Var arr) = appliedF+ let [realfun] = get_val_args (Var.varType arr) alreadyMappedArgs+ -- Create 2 new Vars of which the 2nd is applied to the lifted function+ let [argTy] = (fst . Type.splitFunTys . CoreUtils.exprType) realfun+ id1 <- Trans.lift $ mkInternalVar "param" TysWiredIn.unitTy+ id2 <- Trans.lift $ mkInternalVar "param" argTy+ -- Return the extracted expression + let realfunapp = App realfun (Var id2)+ let realfunpack = MkCore.mkCoreTup [MkCore.mkCoreTup [],realfunapp]+ change (Lam id1 (Lam id2 (realfunpack)))+ where+ (appliedF, alreadyMappedArgs) = collectArgs expr+ +-- Leave all other expressions unchanged +arrowLiftExtract c e = return e +-------------------------------------+-- return value (returnA) extraction +-------------------------------------+-- The returnA function normally returns the value of an Arrow, it is replaced+-- by a statefull identity function+-- +-- From: +-- (returnA :: (Arrow a) => a b b)+-- +-- To: +-- \() (x::b) -> ((), x)+arrowReturnExtract :: Transform+arrowReturnExtract c expr@(Var f) | ((Name.getOccString f) == "returnA") = do+ -- Create 2 new Vars of which the 2nd is of the value type of the arrow+ let arg_ty = (head . snd . Type.splitTyConApp . CoreUtils.exprType) expr+ id1 <- Trans.lift $ mkInternalVar "param" TysWiredIn.unitTy+ id2 <- Trans.lift $ mkInternalVar "param" arg_ty+ -- Return the extracted expression + let packinps = MkCore.mkCoreTup [MkCore.mkCoreTup [],Var id2]+ change (Lam id1 (Lam id2 packinps))++-- Leave all other expressions unchanged +arrowReturnExtract c e = return e++--------------------------------+-- arrow hooks (>>>) extraction+--------------------------------+-- The (>>>) function composes 2 arrows into 1:+-- +-- ----- -----+-- β --> | f | --> γ >>> γ ---> | g | ---> δ+-- ----- -----+-- +-- It is replaced by a statefull function that evaluates the 2 lifted +-- functions in a letbinding and returns the result of the 2nd function.+-- +-- From: +-- (>>>) (f :: s1 -> β -> (s1,γ)) (g :: s2 -> γ -> (s2,δ))+-- +-- To: +-- \((s::(s1,s2)) (β::β) -> letrec+-- s1 = case s of (s1,s2) -> s1+-- s2 = case s of (s1,s2) -> s2+-- fout = f s1 β+-- s1' = case fout of (s1',γ) -> s1'+-- γ = case fout of (s1',γ) -> γ+-- gout = g s2 γ+-- s2' = case fout of (s2',δ) -> s2'+-- δ = case fout of (s2',δ) -> δ+-- aout = ((s1',s2'),δ)+-- in+-- aout+arrowHooksExtract :: Transform+arrowHooksExtract c expr@(App _ _) | isArrHooks (appliedF, alreadyMappedArgs) = do+ -- Collect the two lifted functions+ let (Var hooks) = appliedF+ let [f,g] = get_val_args (Var.varType hooks) alreadyMappedArgs+ -- Collect the types and expression for f+ realF <- if isArrowE f+ -- If f is still an arrow, arrow-normalize it first + then do+ case f of+ -- If it's a variable reference, make sure the referenced expression+ -- is normalized, and return the bndr for the normalized expression + (Var bndr) -> extractArrowExpression bndr+ -- Otherwise, just normalize the expression+ otherwise -> Trans.lift $ normalizeExpr "hookleft" aTransforms f+ else + return f+ -- Collect the types and expression for g+ realG <- if isArrowE g+ -- If g is still an arrow, arrow-normalize it first+ then do+ case g of+ -- If it's a variable reference, make sure the referenced expression+ -- is normalized, and return the bndr for the normalized expression+ (Var bndr) -> extractArrowExpression bndr+ -- Otherwise, just normalize the expression+ otherwise -> Trans.lift $ normalizeExpr "hookright" aTransforms g+ else + return g+ let [([fStateTy,fInpTy], fResTy),([gStateTy,gInpTy], gResTy)] = map (Type.splitFunTys . CoreUtils.exprType) [realF,realG]+ -- Create the State input type of the combined functions+ let stateTy = MkCore.mkCoreTupTy [fStateTy,gStateTy]+ stateId <- Trans.lift $ mkInternalVar "inputStateHooks" stateTy+ inputId <- Trans.lift $ mkInternalVar "inputHooks" fInpTy+ -- Unpack the states of functions f and g+ fStateScrutId <- Trans.lift $ mkInternalVar "fStateScrutHooks" fStateTy+ gStateScrutId <- Trans.lift $ mkInternalVar "gStateScrutHooks" gStateTy+ fStateId <- Trans.lift $ mkInternalVar "fStateHooks" fStateTy+ gStateId <- Trans.lift $ mkInternalVar "gStateHooks" gStateTy+ stateSelbndr <- Trans.lift $ mkInternalVar "stateSelHooks" stateTy + let unpackFState = MkCore.mkSmallTupleSelector [fStateScrutId,gStateScrutId] fStateScrutId stateSelbndr (Var stateId)+ let unpackGState = MkCore.mkSmallTupleSelector [fStateScrutId,gStateScrutId] gStateScrutId stateSelbndr (Var stateId)+ -- Unpack the updated state and output of f+ fResultId <- Trans.lift $ mkInternalVar "fResultHooks" fResTy+ fStatePrimeScrutId <- Trans.lift $ mkInternalVar "fStatePrimeScrutHooks" fStateTy+ gammaScrutId <- Trans.lift $ mkInternalVar "gammaScrutHooks" gInpTy+ fStatePrimeId <- Trans.lift $ mkInternalVar "fStatePrimeHooks" fStateTy+ gammaId <- Trans.lift $ mkInternalVar "gammaHooks" gInpTy+ fResultSelbndr <- Trans.lift $ mkInternalVar "fResultSelHooks" fResTy + let unpackFStatePrime = MkCore.mkSmallTupleSelector [fStatePrimeScrutId,gammaScrutId] fStatePrimeScrutId fResultSelbndr (Var fResultId)+ let unpackGamma = MkCore.mkSmallTupleSelector [fStatePrimeScrutId,gammaScrutId] gammaScrutId fResultSelbndr (Var fResultId)+ -- Unpack the updated state and output of g+ let deltaType = (last . snd . Type.splitTyConApp) gResTy+ gResultId <- Trans.lift $ mkInternalVar "gResultHooks" gResTy+ gStatePrimeScrutId <- Trans.lift $ mkInternalVar "gStatePrimeScrutHooks" gStateTy+ deltaScrutId <- Trans.lift $ mkInternalVar "deltaScrutHooks" deltaType + gStatePrimeId <- Trans.lift $ mkInternalVar "gStatePrimeHooks" gStateTy+ deltaId <- Trans.lift $ mkInternalVar "deltaHooks" deltaType+ gResultSelbndr <- Trans.lift $ mkInternalVar "gResultSelHooks" gResTy + let unpackGStatePrime = MkCore.mkSmallTupleSelector [gStatePrimeScrutId,deltaScrutId] gStatePrimeScrutId gResultSelbndr (Var gResultId)+ let unpackDelta = MkCore.mkSmallTupleSelector [gStatePrimeScrutId,deltaScrutId] deltaScrutId gResultSelbndr (Var gResultId)+ -- Pack the update state, and pack the result of g+ let resPack = MkCore.mkCoreTup [MkCore.mkCoreTup [Var fStatePrimeId, Var gStatePrimeId], Var deltaId]+ arrowHooksOutId <- Trans.lift $ mkInternalVar "arrowHooksOut" (CoreUtils.exprType (resPack))+ let letexprs = Rec [(fStateId, unpackFState)+ ,(gStateId, unpackGState)+ , (fResultId, (App (App realF (Var fStateId)) (Var inputId)))+ , (fStatePrimeId, unpackFStatePrime)+ , (gammaId, unpackGamma)+ , (gResultId, (App (App realG (Var gStateId)) (Var gammaId)))+ , (gStatePrimeScrutId, unpackGStatePrime)+ , (deltaId, unpackDelta)+ , (arrowHooksOutId, resPack)+ ]+ let letExpression = MkCore.mkCoreLets [letexprs] (Var arrowHooksOutId) + change (Lam stateId (Lam inputId (letExpression)))+ where+ (appliedF, alreadyMappedArgs) = collectArgs expr ++-- Leave all other expressions unchanged +arrowHooksExtract c e = return e++--------------------------------+-- arrow first extraction+--------------------------------+-- The first function encapsulates arrow in a larger arrow which has a input+-- tuple and an output tuple. The inner arrow is applied to the first value+-- of the tuple:+-- +-- -------------+-- | ----- | +-- β ---|-> | f | --|--> γ +-- | ----- |+-- δ ---|-----------|--> δ+-- -------------+-- +-- It is replaced by a statefull function that evaluates the lifted +-- function in a letbinding and returns the result as part of the tuple.+-- +-- From: +-- first (f :: s -> β -> (s,γ))+-- +-- To: +-- \(s::s) (i::(β,δ)) -> letrec+-- β = case i of (β,δ) -> β+-- δ = case i of (β,δ) -> δ+-- fout = f s β+-- s' = case fout of (s',γ) -> s'+-- γ = case fout of (s',γ) -> γ+-- aout = (s',(γ,δ))+-- in+-- aout+arrowFirstExtract :: Transform+arrowFirstExtract c expr@(App _ _) | isArrFirst (appliedF, alreadyMappedArgs) = do+ let (Var first) = appliedF+ -- Get type of delta and gamma+ let deltaTy = (last . snd . Type.splitTyConApp . head . snd . Type.splitTyConApp . CoreUtils.exprType) expr+ let gammaTy = (head . snd . Type.splitTyConApp . last . snd . Type.splitTyConApp . CoreUtils.exprType) expr+ -- Retreive the packed functions + let [f] = get_val_args (Var.varType first) alreadyMappedArgs+ -- Get the State, Input and Result type of the packed function+ realF <- if isArrowE f+ -- If f is still an arrow, arrow-normalize it first + then do+ case f of+ -- If it's a variable reference, make sure the referenced expression+ -- is normalized, and return the bndr for the normalized expression+ (Var bndr) -> extractArrowExpression bndr+ -- Otherwise, just normalize the expression+ otherwise -> Trans.lift $ normalizeExpr "first" aTransforms f+ else + return f+ let ([fStateTy,fInpTy], fResTy) = (Type.splitFunTys . CoreUtils.exprType) realF+ -- Create a new input type that is a combination of the input of 'f' and delta+ let inputTy = MkCore.mkCoreTupTy [fInpTy,deltaTy]+ inputStateId <- Trans.lift $ mkInternalVar "inputStateFirst" fStateTy+ inputId <- Trans.lift $ mkInternalVar "inputFirst" inputTy+ -- Unpack input into input for function f and delta+ fInputScrutId <- Trans.lift $ mkInternalVar "fInputScrutFirst" fInpTy+ deltaScrutId <- Trans.lift $ mkInternalVar "deltaScrutFirst" deltaTy+ fInput <- Trans.lift $ mkInternalVar "fInputFirst" fInpTy+ deltaId <- Trans.lift $ mkInternalVar "deltaFirst" deltaTy+ let unpackFInput = MkCore.mkSmallTupleSelector [fInputScrutId,deltaScrutId] fInputScrutId (MkCore.mkWildBinder inputTy) (Var inputId)+ let unpackDelta = MkCore.mkSmallTupleSelector [fInputScrutId,deltaScrutId] deltaScrutId (MkCore.mkWildBinder inputTy) (Var inputId)+ -- Unpack the updated state of 'f' and its output+ fResultId <- Trans.lift $ mkInternalVar "fResultFirst" fResTy+ fStatePrimeScrutId <- Trans.lift $ mkInternalVar "fStatePrimeScrutFirst" fStateTy+ gammaScrutId <- Trans.lift $ mkInternalVar "gammaScrutFirst" gammaTy+ fStatePrimeId <- Trans.lift $ mkInternalVar "fStatePrimeFirst" fStateTy+ gammaId <- Trans.lift $ mkInternalVar "gammaFirst" gammaTy+ let unpackFStatePrime = MkCore.mkSmallTupleSelector [fStatePrimeScrutId,gammaScrutId] fStatePrimeScrutId (MkCore.mkWildBinder fResTy) (Var fResultId)+ let unpackGamma = MkCore.mkSmallTupleSelector [fStatePrimeScrutId,gammaScrutId] gammaScrutId (MkCore.mkWildBinder fResTy) (Var fResultId)+ -- Pack the update state, and pack the result of f and delta+ let resPack = MkCore.mkCoreTup [Var fStatePrimeId, MkCore.mkCoreTup [Var gammaId, Var deltaId]]+ arrowFirstOutId <- Trans.lift $ mkInternalVar "arrowFirstOut" (CoreUtils.exprType (resPack))+ let letexprs = Rec [ (fInput, unpackFInput)+ , (deltaId, unpackDelta)+ , (fResultId, (App (App realF (Var inputStateId)) (Var fInput)))+ , (fStatePrimeId, unpackFStatePrime)+ , (gammaId, unpackGamma)+ , (arrowFirstOutId, resPack)+ ]+ let letExpression = MkCore.mkCoreLets [letexprs] (Var arrowFirstOutId) + change (Lam inputStateId (Lam inputId (letExpression)))+ where+ (appliedF, alreadyMappedArgs) = collectArgs expr++-- Leave all other expressions unchanged+arrowFirstExtract c e = return e++--------------------------------+-- arrow loop extraction+--------------------------------+-- The loop function feeds back the latter part of the outputtuple of an arrow +-- +-- ------- +-- β ---> | | ---> γ +-- | f |+-- ---> | | --- +-- | ------- |+-- ----------------+-- δ+-- +-- It is replaced by a statefull function that evaluates the lifted +-- function in a letbinding and feeds back part of the result to itself+-- +-- From: +-- loop (f :: s -> (β,δ) -> (s,(γ,δ))+-- +-- To: +-- \(s::s) (i::(β,δ)) -> letrec+-- i = (β,δ)+-- fout = f s i+-- s' = case fout of (s',fres) -> s'+-- fres = case fout of (s',fres) -> fres+-- γ = case fres of (γ,δ) -> γ+-- δ = case fres of (γ,δ) -> δ+-- aout = (s',γ)+-- in+-- aout+arrowLoopExtract :: Transform+arrowLoopExtract c expr@(App _ _) | isArrLoop (appliedF, alreadyMappedArgs) = do+ let (Var loop) = appliedF+ let [f] = get_val_args (Var.varType loop) alreadyMappedArgs+ -- Get the State, Input and Result type of the packed function+ realF <- if isArrowE f + -- If f is still an arrow, arrow-normalize it first + then do+ case f of+ -- If it's a variable reference, make sure the referenced expression+ -- is normalized, and return the bndr for the normalized expression+ (Var bndr) -> extractArrowExpression bndr+ -- Otherwise, just normalize the expression+ otherwise -> Trans.lift $ normalizeExpr "arrowLoop" aTransforms f+ else + return f+ let ([fStateTy,fInpTy], fResTy) = (Type.splitFunTys . CoreUtils.exprType) realF+ let [betaTy,deltaTy] = (snd . Type.splitTyConApp) fInpTy+ let fOutTy = (last . snd . Type.splitTyConApp) fResTy+ let gammaTy = (head . snd . Type.splitTyConApp) fOutTy+ betaId <- Trans.lift $ mkInternalVar "betaLoop" betaTy+ deltaId <- Trans.lift $ mkInternalVar "deltaLoop" deltaTy+ gammaId <- Trans.lift $ mkInternalVar "gammaLoop" gammaTy+ deltaScrutId <- Trans.lift $ mkInternalVar "deltaScrutLoop" deltaTy+ gammaScrutId <- Trans.lift $ mkInternalVar "gammaScrutLoop" gammaTy+ fInput <- Trans.lift $ mkInternalVar "fInputLoop" fInpTy+ inputStateId <- Trans.lift $ mkInternalVar "inputStateLoop" fStateTy+ let inputPack = MkCore.mkCoreTup [Var betaId, Var deltaId]+ fResultId <- Trans.lift $ mkInternalVar "fResultLoop" fResTy+ fOutId <- Trans.lift $ mkInternalVar "fOutLoop" fOutTy+ fOutScrutId <- Trans.lift $ mkInternalVar "fOutScrutLoop" fOutTy+ fStatePrimeId <- Trans.lift $ mkInternalVar "fStatePrimeLoop" fStateTy+ fStatePrimeScrutId <- Trans.lift $ mkInternalVar "fStatePrimeScrutLoop" fStateTy+ let unpackFStatePrime = MkCore.mkSmallTupleSelector [fStatePrimeScrutId,fOutScrutId] fStatePrimeScrutId (MkCore.mkWildBinder fResTy) (Var fResultId)+ let unpackFOut = MkCore.mkSmallTupleSelector [fStatePrimeScrutId,fOutScrutId] fOutScrutId (MkCore.mkWildBinder fResTy) (Var fResultId)+ let unpackGamma = MkCore.mkSmallTupleSelector [gammaScrutId,deltaScrutId] gammaScrutId (MkCore.mkWildBinder fOutTy) (Var fOutId)+ let unpackDelta = MkCore.mkSmallTupleSelector [gammaScrutId,deltaScrutId] deltaScrutId (MkCore.mkWildBinder fOutTy) (Var fOutId)+ let resPack = MkCore.mkCoreTup [Var fStatePrimeId, Var gammaId]+ arrowLoopOutId <- Trans.lift $ mkInternalVar "arrowLoopOut" (CoreUtils.exprType (resPack))+ let letexprs = Rec [ (fInput, inputPack)+ , (fResultId, (App (App realF (Var inputStateId)) (Var fInput)))+ , (fStatePrimeId, unpackFStatePrime)+ , (fOutId, unpackFOut)+ , (gammaId, unpackGamma)+ , (deltaId, unpackDelta)+ , (arrowLoopOutId, resPack)+ ]+ let letExpression = MkCore.mkCoreLets [letexprs] (Var arrowLoopOutId)+ change (Lam inputStateId (Lam betaId (letExpression)))+ where+ (appliedF, alreadyMappedArgs) = collectArgs expr++-- Leave all other expressions unchanged +arrowLoopExtract c e = return e++--------------------------------+-- End of transformations+--------------------------------+ -- What transforms to run? transforms = [ ("inlinedict", inlinedict) , ("inlinetoplevel", inlinetoplevel)@@ -979,6 +1423,21 @@ , ("castsimpl", castsimpl) ] +-- What transforms to apply to get rid of arrows+aTransforms = [ ("inlinenonrep", inlinenonrep)+ , ("letrec", letrec)+ , ("inlineArrowHooks", inlineArrowHooks)+ , ("letremove", letremove)+ , ("beta", beta)+ , ("eta", eta)+ , ("arrowLiftSExtract", arrowLiftSExtract)+ , ("arrowLiftExtract", arrowLiftExtract)+ , ("arrowReturnExtract", arrowReturnExtract)+ , ("arrowHooksExtract", arrowHooksExtract)+ , ("arrowFirstExtract", arrowFirstExtract)+ , ("arrowLoopExtract", arrowLoopExtract) + ]+ -- | Returns the normalized version of the given function, or an error -- if it is not a known global binder. getNormalized ::@@ -999,32 +1458,71 @@ -> TranslatorSession (Maybe CoreExpr) -- The normalized function body getNormalized_maybe result_nonrep bndr = do- expr_maybe <- getGlobalBind bndr- normalizeable <- isNormalizeable result_nonrep bndr- if not normalizeable || Maybe.isNothing expr_maybe- then- -- Binder not normalizeable or not found- return Nothing- else do- -- Binder found and is monomorphic. Normalize the expression- -- and cache the result.- normalized <- Utils.makeCached bndr tsNormalized $ - normalizeExpr (show bndr) (Maybe.fromJust expr_maybe)- return (Just normalized)+ expr_maybe <- getGlobalBind bndr+ case (isArrowB bndr, expr_maybe, isLiftMaybe expr_maybe) of+ -- The bndr is an Arrow, and it is the lifting function+ (True, Just arrowf, True) -> do+ -- Collect the lifted function and the initial state+ let (CoreSyn.Var liftfun, already_mapped_args) = CoreSyn.collectArgs arrowf+ let [Var realfun, Var initvalue] = get_val_args (Var.varType liftfun) already_mapped_args+ -- Normalize the lifted function+ normalized <- getNormalized_maybe result_nonrep realfun+ realfun' <- mkFunction realfun $ Maybe.fromMaybe (error $ "Normalize.getNormalized_maybe(Arrow.liftS): lifted function " ++ pprString realfun ++ "could not be normalized") normalized+ -- Associate initial state with lifted function+ MonadState.modify tsInitStates (Map.insert realfun' initvalue)+ -- Make a mapping from the arrow to the lifted function+ MonadState.modify tsArrows (Map.insert bndr realfun')+ return normalized+ -- The bndr is an Arrow (but not the lifting function)+ (True, Just arrowf, False) -> do+ normalizedA <- Utils.makeCached bndr tsNormalized $ do {+ -- First apply the transformations that remove the arrows+ ; arrowLessExpr <- normalizeExpr (show bndr) aTransforms arrowf+ -- Secondly apply the standard normalization transformations+ ; normalizeExpr (show bndr) transforms arrowLessExpr+ }+ normalizeable <- isNormalizeableE result_nonrep normalizedA+ if not normalizeable+ then+ return Nothing+ else do+ realfun <- mkFunction bndr normalizedA+ MonadState.modify tsArrows (Map.insert bndr realfun)+ return (Just normalizedA)+ -- The expression is not an Arrow+ (False, Just expr, False) -> do+ normalizeable <- isNormalizeable result_nonrep bndr+ if not normalizeable+ then+ -- Binder not normalizeable+ return Nothing+ else do+ -- Binder found and is monomorphic. Normalize the expression+ -- and cache the result.+ normalized <- Utils.makeCached bndr tsNormalized $ + normalizeExpr (show bndr) transforms expr+ return (Just normalized)+ -- No expression belonging to this binder found+ otherwise -> return Nothing+ where+ isLiftMaybe :: Maybe CoreExpr -> Bool+ isLiftMaybe Nothing = False+ isLiftMaybe (Just x) = (isLift . CoreSyn.collectArgs) x -- | Normalize an expression normalizeExpr :: String -- ^ What are we normalizing? For debug output only.+ -> [(String, Transform)] -- ^ What transformations we are applying -> CoreSyn.CoreExpr -- ^ The expression to normalize -> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression -normalizeExpr what expr = do+normalizeExpr what normTransforms expr = do startcount <- MonadState.get tsTransformCounter expr_uniqued <- genUniques expr -- Do a debug print, if requested let expr_uniqued' = Utils.traceIf (normalize_debug >= NormDbgFinal) (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr_uniqued ) ++ "\n") expr_uniqued -- Normalize this expression- expr' <- dotransforms transforms expr_uniqued'+ expr' <- dotransforms normTransforms expr_uniqued' endcount <- MonadState.get tsTransformCounter -- Do a debug print, if requested Utils.traceIf (normalize_debug >= NormDbgFinal) (what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr') ++ "\nNeeded " ++ show (endcount - startcount) ++ " transformations to normalize " ++ what) $
CLasH/Normalize/NormalizeTools.hs view
@@ -18,6 +18,8 @@ import qualified CoreSubst import qualified Type import qualified CoreUtils+import qualified TyCon+import qualified Var import Outputable ( showSDoc, ppr, nest ) -- Local imports@@ -80,22 +82,30 @@ return $ App a' b' subeverywhere trans c (Let (NonRec b bexpr) expr) = do- bexpr' <- trans (LetBinding:c) bexpr- expr' <- trans (LetBody:c) expr+ -- In the binding of a non-recursive let binding, no extra binders are+ -- in scope.+ bexpr' <- trans (LetBinding []:c) bexpr+ -- In the body of a non-recursive let binding, the bound binder is in+ -- scope.+ expr' <- trans ((LetBody [b]):c) expr return $ Let (NonRec b bexpr') expr' subeverywhere trans c (Let (Rec binds) expr) = do- expr' <- trans (LetBody:c) expr+ -- In the body of a recursive let, all binders are in scope+ expr' <- trans ((LetBody bndrs):c) expr binds' <- mapM transbind binds return $ Let (Rec binds') expr' where+ bndrs = map fst binds transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr) transbind (b, e) = do- e' <- trans (LetBinding:c) e+ -- In the bindings of a recursive let, all binders are in scope+ e' <- trans ((LetBinding bndrs):c) e return (b, e') subeverywhere trans c (Lam x expr) = do- expr' <- trans (LambdaBody:c) expr+ -- In the body of a lambda, the bound binder is in scope.+ expr' <- trans ((LambdaBody x):c) expr return $ Lam x expr' subeverywhere trans c (Case scrut b t alts) = do@@ -105,18 +115,19 @@ where transalt :: CoreAlt -> TransformMonad CoreAlt transalt (con, binders, expr) = do- expr' <- trans (Other:c) expr+ expr' <- trans ((CaseAlt b):c) expr return (con, binders, expr') subeverywhere trans c (Var x) = return $ Var x subeverywhere trans c (Lit x) = return $ Lit x subeverywhere trans c (Type x) = return $ Type x+subeverywhere trans c (Note msg expr) = trans (Other:c) expr subeverywhere trans c (Cast expr ty) = do expr' <- trans (Other:c) expr return $ Cast expr' ty -subeverywhere trans c expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr+-- subeverywhere trans c expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr -- Runs each of the transforms repeatedly inside the State monad. dotransforms :: [(String, Transform)] -> CoreExpr -> TranslatorSession CoreExpr@@ -154,12 +165,15 @@ reps' <- mapM (subs_bind bndr val) reps -- And then perform the remaining substitutions do_substitute reps' expr'++ -- All binders bound in the transformed recursive let+ bndrs = map fst binds -- Replace the given binder with the given expression in the -- expression oft the given let binding subs_bind :: CoreBndr -> CoreExpr -> (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr) subs_bind bndr expr (b, v) = do- v' <- substitute_clone bndr expr (LetBinding:context) v+ v' <- substitute_clone bndr expr ((LetBinding bndrs):context) v return (b, v') @@ -216,7 +230,10 @@ is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool is_local_var (CoreSyn.Var v) = do bndrs <- getGlobalBinders- return $ v `notElem` bndrs+ -- A datacon id is not a global binder, but not a local variable+ -- either.+ let is_dc = Id.isDataConWorkId v+ return $ not is_dc && v `notElem` bndrs is_local_var _ = return False -- Is the given binder defined by the user?@@ -243,3 +260,63 @@ let (arg_tys, res_ty) = Type.splitFunTys ty let check_tys = if result_nonrep then arg_tys else (res_ty:arg_tys) andM $ mapM isRepr' check_tys++isNormalizeableE :: + Bool -- ^ Allow the result to be unrepresentable?+ -> CoreExpr -- ^ The binder to check+ -> TranslatorSession Bool -- ^ Is it normalizeable?+isNormalizeableE result_nonrep expr = do+ let ty = CoreUtils.exprType expr+ let (arg_tys, res_ty) = Type.splitFunTys ty+ let check_tys = if result_nonrep then arg_tys else (res_ty:arg_tys) + andM $ mapM isRepr' check_tys++isArrowB ::+ CoreBndr+ -> Bool+isArrowB bndr = res+ where+ ty = Id.idType bndr+ res = case Type.splitTyConApp_maybe ty of+ Just (tycon, args) -> Name.getOccString (TyCon.tyConName tycon) == "Stat"+ Nothing -> False++isArrowE ::+ CoreExpr+ -> Bool+isArrowE expr = res+ where+ ty = CoreUtils.exprType expr+ res = case Type.splitTyConApp_maybe ty of+ Just (tycon, args) -> (Name.getOccString (TyCon.tyConName tycon)) == "Stat"+ Nothing -> False+ +isLift ::+ (CoreExpr, [CoreExpr])+ -> Bool+isLift ((Var bndr), args) = (Name.getOccString bndr) == "^^^" && (length $ CoreTools.get_val_args (Var.varType bndr) args) == 2+isLift _ = False+ +isArrHooks ::+ (CoreExpr, [CoreExpr])+ -> Bool+isArrHooks ((Var bndr), args) = (Name.getOccString bndr) == ">>>" && (length $ CoreTools.get_val_args (Var.varType bndr) args) == 2+isArrHooks _ = False + +isArrLift ::+ (CoreExpr, [CoreExpr])+ -> Bool+isArrLift ((Var bndr), args) = (Name.getOccString bndr) == "arr" && (length $ CoreTools.get_val_args (Var.varType bndr) args) == 1+isArrLift _ = False ++isArrFirst ::+ (CoreExpr, [CoreExpr])+ -> Bool+isArrFirst ((Var bndr), args) = (Name.getOccString bndr) == "first" && (length $ CoreTools.get_val_args (Var.varType bndr) args) == 1+isArrFirst _ = False++isArrLoop ::+ (CoreExpr, [CoreExpr])+ -> Bool+isArrLoop ((Var bndr), args) = (Name.getOccString bndr) == "loop" && (length $ CoreTools.get_val_args (Var.varType bndr) args) == 1+isArrLoop _ = False
CLasH/Normalize/NormalizeTypes.hs view
@@ -21,14 +21,39 @@ | AppSecond -- ^ The expression is the second -- argument of an application -- (i.e., something is applied to it)- | LetBinding -- ^ The expression is bound in a+ | LetBinding [CoreSyn.CoreBndr]+ -- ^ The expression is bound in a -- (recursive or non-recursive) let -- expression.- | LetBody -- ^ The expression is the body of a+ | LetBody [CoreSyn.CoreBndr]+ -- ^ The expression is the body of a -- let expression- | LambdaBody -- ^ The expression is the body of a+ | LambdaBody CoreSyn.CoreBndr+ -- ^ The expression is the body of a -- lambda abstraction+ | CaseAlt CoreSyn.CoreBndr+ -- ^ The expression is the body of a+ -- case alternative. | Other -- ^ Another context deriving (Eq, Show) -- | Transforms a CoreExpr and keeps track if it has changed. type Transform = [CoreContext] -> CoreSyn.CoreExpr -> TransformMonad CoreSyn.CoreExpr++-- Predicates for each of the context types+is_appfirst_ctx, is_appsecond_ctx, is_letbinding_ctx, is_letbody_ctx, is_lambdabody_ctx+ :: CoreContext -> Bool++is_appfirst_ctx AppFirst = True+is_appfirst_ctx _ = False++is_appsecond_ctx AppSecond = True+is_appsecond_ctx _ = False++is_letbinding_ctx (LetBinding _) = True+is_letbinding_ctx _ = False++is_letbody_ctx (LetBody _) = True+is_letbody_ctx _ = False++is_lambdabody_ctx (LambdaBody _) = True+is_lambdabody_ctx _ = False
CLasH/Translator.hs view
@@ -112,8 +112,9 @@ -- on the compiler dir of ghc suggests that 'z' is not used to generate -- a unique supply anywhere. uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'- let init_typestate = TypeState builtin_types [] Map.empty Map.empty env- let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty 0+ let init_typedecls = map (mktydecl . Maybe.fromJust . snd) $ Map.toList builtin_types+ let init_typestate = TypeState builtin_types init_typedecls Map.empty Map.empty env+ let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty 0 Map.empty return $ State.evalState session init_state -- | Prepares the directory for writing VHDL files. This means creating the
CLasH/Translator/TranslatorTypes.hs view
@@ -45,14 +45,21 @@ instance Ord OrdType where compare (OrdType a) (OrdType b) = Type.tcCmpType a b -data HType = AggrType String [HType] |+data HType = AggrType String (Maybe (String, HType)) [[(String, HType)]] |+ -- ^ A type containing multiple fields. Arguments: Type+ -- name, an optional EnumType for the constructors (if > 1)+ -- and a list containing a list of fields (name, htype) for+ -- each constructor. EnumType String [String] |+ -- ^ A type containing no fields and multiple constructors.+ -- Arguments: Type name, a list of possible values. VecType Int HType | UVecType HType | SizedWType Int | RangedWType Int | SizedIType Int | BuiltinType String |+ UnitType | StateType deriving (Eq, Ord, Show) @@ -94,6 +101,7 @@ , tsArchitectures_ :: Map.Map CoreSyn.CoreBndr (Architecture, [CoreSyn.CoreBndr]) , tsInitStates_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreBndr , tsTransformCounter_ :: Int -- ^ How many transformations were applied?+ , tsArrows_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreBndr } -- Derive accessors
CLasH/Utils/Core/CoreTools.hs view
@@ -7,6 +7,7 @@ --Standard modules import qualified Maybe+import qualified List import qualified System.IO.Unsafe import qualified Data.Map as Map import qualified Data.Accessor.Monad.Trans.State as MonadState@@ -34,6 +35,7 @@ import qualified Literal import qualified MkCore import qualified VarEnv+import qualified Outputable -- Local imports import CLasH.Translator.TranslatorTypes@@ -147,6 +149,27 @@ Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty) [len, el_ty] = args +-- | Gets the index of the given datacon in the given typed thing.+-- Errors out if it does not occur or if the type is not an ADT.+datacon_index :: TypedThing t => t -> DataCon.DataCon -> Int+datacon_index tt dc = case List.elemIndex dc dcs of+ Nothing -> error $ "Datacon " ++ pprString dc ++ " does not occur in typed thing: " ++ pprString tt+ Just i -> i+ where+ dcs = datacons_for tt++-- | Gets all datacons for the given typed thing. Errors out if the+-- typed thing is not ADT typed.+datacons_for :: TypedThing t => t -> [DataCon.DataCon]+datacons_for tt =+ case getType tt of+ Nothing -> error $ "Getting datacon index of untyped thing? " ++ pprString tt+ Just ty -> case Type.splitTyConApp_maybe ty of+ Nothing -> error $ "Trying to find datacon in a type without a tycon?" ++ pprString ty+ Just (tycon, _) -> case TyCon.tyConDataCons_maybe tycon of+ Nothing -> error $ "Trying to find datacon in a type without datacons?" ++ pprString ty+ Just dcs -> dcs+ -- Is the given core expression a lambda abstraction? is_lam :: CoreSyn.CoreExpr -> Bool is_lam (CoreSyn.Lam _ _) = True@@ -347,7 +370,7 @@ -- | A class of things that (optionally) have a core Type. The type is -- optional, since Type expressions don't have a type themselves.-class TypedThing t where+class Outputable.Outputable t => TypedThing t where getType :: t -> Maybe Type.Type instance TypedThing CoreSyn.CoreExpr where@@ -438,26 +461,34 @@ let subst' = VarEnv.extendVarEnv subst bndr bndr' return (subst', bndr') --- Create a "selector" case that selects the ith field from a datacon-mkSelCase :: CoreSyn.CoreExpr -> Int -> TranslatorSession CoreSyn.CoreExpr-mkSelCase scrut i = do- let scrut_ty = CoreUtils.exprType scrut+-- Create a "selector" case that selects the ith field from dc_ith+-- datacon+mkSelCase :: CoreSyn.CoreExpr -> Int -> Int -> TranslatorSession CoreSyn.CoreExpr+mkSelCase scrut dc_i i = do case Type.splitTyConApp_maybe scrut_ty of -- The scrutinee should have a type constructor. We keep the type -- arguments around so we can instantiate the field types below- Just (tycon, tyargs) -> case TyCon.tyConDataCons tycon of+ Just (tycon, tyargs) -> case TyCon.tyConDataCons_maybe tycon of -- The scrutinee type should have a single dataconstructor, -- otherwise we can't construct a valid selector case.- [datacon] -> do- let field_tys = DataCon.dataConInstOrigArgTys datacon tyargs- -- Create a list of wild binders for the fields we don't want- let wildbndrs = map MkCore.mkWildBinder field_tys- -- Create a single binder for the field we want- sel_bndr <- mkInternalVar "sel" (field_tys!!i)- -- Create a wild binder for the scrutinee- let scrut_bndr = MkCore.mkWildBinder scrut_ty- -- Create the case expression- let binders = take i wildbndrs ++ [sel_bndr] ++ drop (i+1) wildbndrs- return $ CoreSyn.Case scrut scrut_bndr scrut_ty [(CoreSyn.DataAlt datacon, binders, CoreSyn.Var sel_bndr)]- dcs -> error $ "CoreTools.mkSelCase: Scrutinee type must have exactly one datacon. Extracting element " ++ (show i) ++ " from '" ++ pprString scrut ++ "' Datacons: " ++ (show dcs) ++ " Type: " ++ (pprString scrut_ty)- Nothing -> error $ "CoreTools.mkSelCase: Creating extractor case, but scrutinee has no tycon? Extracting element " ++ (show i) ++ " from '" ++ pprString scrut ++ "'" ++ " Type: " ++ (pprString scrut_ty)+ Just dcs | dc_i < 0 || dc_i >= length dcs -> error $ "\nCoreTools.mkSelCase: Creating extractor case, but datacon index is invalid." ++ error_msg+ | otherwise -> do+ let datacon = (dcs!!dc_i)+ let field_tys = DataCon.dataConInstOrigArgTys datacon tyargs+ if i < 0 || i >= length field_tys+ then error $ "\nCoreTools.mkSelCase: Creating extractor case, but field index is invalid." ++ error_msg+ else do+ -- Create a list of wild binders for the fields we don't want+ let wildbndrs = map MkCore.mkWildBinder field_tys+ -- Create a single binder for the field we want+ sel_bndr <- mkInternalVar "sel" (field_tys!!i)+ -- Create a wild binder for the scrutinee+ let scrut_bndr = MkCore.mkWildBinder scrut_ty+ -- Create the case expression+ let binders = take i wildbndrs ++ [sel_bndr] ++ drop (i+1) wildbndrs+ return $ CoreSyn.Case scrut scrut_bndr scrut_ty [(CoreSyn.DataAlt datacon, binders, CoreSyn.Var sel_bndr)]+ Nothing -> error $ "CoreTools.mkSelCase: Creating extractor case, but scrutinee has no datacons?" ++ error_msg+ Nothing -> error $ "CoreTools.mkSelCase: Creating extractor case, but scrutinee has no tycon?" ++ error_msg+ where+ scrut_ty = CoreUtils.exprType scrut+ error_msg = " Extracting element " ++ (show i) ++ " from datacon " ++ (show dc_i) ++ " from '" ++ pprString scrut ++ "'" ++ " Type: " ++ (pprString scrut_ty)
CLasH/Utils/Pretty.hs view
@@ -1,8 +1,10 @@-module CLasH.Utils.Pretty (prettyShow, pprString, pprStringDebug) where+module CLasH.Utils.Pretty (prettyShow, pprString, pprStringDebug, zEncodeString) where -- Standard imports import qualified Data.Map as Map import Text.PrettyPrint.HughesPJClass+import Data.Char+import Numeric -- GHC API import qualified CoreSyn@@ -79,3 +81,78 @@ pprStringDebug :: (Outputable x) => x -> String pprStringDebug = showSDocDebug . ppr+++type UserString = String -- As the user typed it+type EncodedString = String -- Encoded form++zEncodeString :: UserString -> EncodedString+zEncodeString cs = case maybe_tuple cs of+ Just n -> n ++ (go cs) -- Tuples go to Z2T etc+ Nothing -> go cs+ where+ go [] = []+ go (c:cs) = encode_digit_ch c ++ go' cs+ go' [] = []+ go' (c:cs) = encode_ch c ++ go' cs++maybe_tuple :: UserString -> Maybe EncodedString++maybe_tuple "(# #)" = Just("Z1H")+maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of+ (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")+ _ -> Nothing+maybe_tuple "()" = Just("Z0T")+maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of+ (n, ')' : _) -> Just ('Z' : shows (n+1) "T")+ _ -> Nothing+maybe_tuple _ = Nothing++count_commas :: Int -> String -> (Int, String)+count_commas n (',' : cs) = count_commas (n+1) cs+count_commas n cs = (n,cs)++encode_digit_ch :: Char -> EncodedString+encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c+encode_digit_ch c | otherwise = encode_ch c++encode_ch :: Char -> EncodedString+encode_ch c | unencodedChar c = [c] -- Common case first++-- Constructors+encode_ch '(' = "ZL" -- Needed for things like (,), and (->)+encode_ch ')' = "ZR" -- For symmetry with (+encode_ch '[' = "ZM"+encode_ch ']' = "ZN"+encode_ch ':' = "ZC"++-- Variables+encode_ch '&' = "za"+encode_ch '|' = "zb"+encode_ch '^' = "zc"+encode_ch '$' = "zd"+encode_ch '=' = "ze"+encode_ch '>' = "zg"+encode_ch '#' = "zh"+encode_ch '.' = "zi"+encode_ch '<' = "zl"+encode_ch '-' = "zm"+encode_ch '!' = "zn"+encode_ch '+' = "zp"+encode_ch '\'' = "zq"+encode_ch '\\' = "zr"+encode_ch '/' = "zs"+encode_ch '*' = "zt"+encode_ch '%' = "zv"+encode_ch c = encode_as_unicode_char c++encode_as_unicode_char :: Char -> EncodedString+encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str+ else '0':hex_str+ where hex_str = showHex (ord c) "U"+ +unencodedChar :: Char -> Bool -- True for chars that don't need encoding+unencodedChar c = c >= 'a' && c <= 'z'+ || c >= 'A' && c <= 'Z'+ || c >= '0' && c <= '9'+ || c == '_'
CLasH/VHDL/Constants.hs view
@@ -8,14 +8,14 @@ -- circular dependencie. builtinIds = [ exId, replaceId, headId, lastId, tailId, initId, takeId, dropId , selId, plusgtId, ltplusId, plusplusId, mapId, zipWithId, foldlId- , foldrId, zipId, unzipId, shiftlId, shiftrId, rotlId, rotrId+ , foldrId, zipId, unzipId, shiftIntoLId, shiftIntoRId, rotlId, rotrId , concatId, reverseId, iteratenId, iterateId, generatenId, generateId , emptyId, singletonId, copynId, copyId, lengthTId, nullId , hwxorId, hwandId, hworId, hwnotId, equalityId, inEqualityId, ltId , lteqId, gtId, gteqId, boolOrId, boolAndId, plusId, timesId , negateId, minusId, fromSizedWordId, fromIntegerId, resizeWordId , resizeIntId, sizedIntId, smallIntegerId, fstId, sndId, blockRAMId- , splitId, minimumId, fromRangedWordId + , splitId, minimumId, fromRangedWordId, xorId, shiftLId , shiftRId ] -------------- -- Identifiers@@ -154,12 +154,12 @@ dropId = "drop" -- | shiftl function identifier-shiftlId :: String-shiftlId = "shiftl"+shiftIntoLId :: String+shiftIntoLId = "shiftIntoL" -- | shiftr function identifier-shiftrId :: String-shiftrId = "shiftr"+shiftIntoRId :: String+shiftIntoRId = "shiftIntoR" -- | rotl function identifier rotlId :: String@@ -241,6 +241,15 @@ hwandId :: String hwandId = "hwand" +xorId :: String+xorId = "xor"++shiftLId :: String+shiftLId = "shiftL"++shiftRId :: String+shiftRId = "shiftR"+ lengthTId :: String lengthTId = "lengthT" @@ -344,7 +353,7 @@ showIdString = "show" showId :: AST.VHDLId-showId = AST.unsafeVHDLExtId showIdString+showId = AST.unsafeVHDLBasicId showIdString -- | write function identifier (from std.textio) writeId :: AST.VHDLId
CLasH/VHDL/Generate.hs view
@@ -20,6 +20,7 @@ import qualified Literal import qualified Name import qualified TyCon+import qualified CoreUtils -- Local imports import CLasH.Translator.TranslatorTypes@@ -133,15 +134,19 @@ -- Create a state proc, if needed (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of ([in_state], [out_state], Nothing) -> do - nonEmpty <- hasNonEmptyType in_state+ nonEmpty <- hasNonEmptyType "\n Generate.getArchitecture (in_state)" in_state if nonEmpty then error ("No initial state defined for: " ++ show fname) else return ([],[]) ([in_state], [out_state], Just resetval) -> do- nonEmpty <- hasNonEmptyType in_state+ nonEmpty <- hasNonEmptyType "" in_state if nonEmpty - then mkStateProcSm (in_state, out_state, resetval)- else error ("Initial state defined for function with only substate: " ++ show fname)+ then mkStateProcSm (in_state, out_state, resetval) + else do+ nonEmptyReset <- hasNonEmptyType "" resetval+ if nonEmptyReset+ then error ("Generate.getArchitecture: Initial state defined for function with only substate: " ++ show fname)+ else return ([],[]) ([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname ([], [], Nothing) -> return ([],[]) (ins, outs, res) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs@@ -229,13 +234,13 @@ -- Simple a = b assignments are just like applications, but without arguments. -- We can't just generate an unconditional assignment here, since b might be a -- top level binding (e.g., a function with no arguments).-mkConcSm (bndr, CoreSyn.Var v) =- genApplication (Left bndr) v []+mkConcSm (bndr, CoreSyn.Var v) = do+ genApplication (Left bndr, Var.varType bndr) v [] mkConcSm (bndr, app@(CoreSyn.App _ _))= do let (CoreSyn.Var f, args) = CoreSyn.collectArgs app let valargs = get_val_args (Var.varType f) args- genApplication (Left bndr) f (map Left valargs)+ genApplication (Left bndr, Var.varType bndr) f (zip (map Left valargs) (map CoreUtils.exprType valargs)) -- A single alt case must be a selector. This means the scrutinee is a simple -- variable, the alternative is a dataalt with a single non-wild binder that@@ -246,12 +251,12 @@ | otherwise = case alt of (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do- nonemptysel <- hasNonEmptyType sel_bndr + nonemptysel <- hasNonEmptyType "\n Generate.mkConcSm (nonemptysel)" sel_bndr if nonemptysel then do- bndrs' <- Monad.filterM hasNonEmptyType bndrs+ bndrs' <- Monad.filterM (hasNonEmptyType ("\n Generate.mkConcSm (bndr'): " ++ show bndrs)) bndrs case List.elemIndex sel_bndr bndrs' of- Just i -> do+ Just sel_i -> do htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut) htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr) case htypeScrt == htypeBndr of@@ -261,9 +266,10 @@ return ([mkUncondAssign (Left bndr) sel_expr], []) otherwise -> case htypeScrt of- Right (AggrType _ _) -> do- labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)- let label = labels!!i+ Right htype@(AggrType _ _ _) -> do+ let dc_i = datacon_index (Id.idType scrut) dc+ let labels = getFieldLabels htype dc_i+ let label = labels!!sel_i let sel_name = mkSelectedName (varToVHDLName scrut) label let sel_expr = AST.PrimName sel_name return ([mkUncondAssign (Left bndr) sel_expr], [])@@ -282,16 +288,37 @@ -- binders in the alts and only variables in the case values and a variable -- for a scrutinee. We check the constructor of the second alt, since the -- first is the default case, if there is any.-mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) _ _ (alt:alts))) = do- scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut- -- Omit first condition, which is the default- altcons <- MonadState.lift tsType $ mapM (altconToVHDLExpr . (\(con,_,_) -> con)) alts- let cond_exprs = map (\x -> scrut' AST.:=: x) altcons+mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) _ _ alts)) = do+ htype <- MonadState.lift tsType $ mkHType ("\nVHDL.mkConcSm: Unrepresentable scrutinee type? Expression: " ++ pprString expr) scrut+ -- Turn the scrutinee into a VHDLExpr+ scrut_expr <- MonadState.lift tsType $ varToVHDLExpr scrut+ (enums, cmp) <- case htype of+ EnumType _ enums -> do+ -- Enumeration type, compare with the scrutinee directly+ return (map (AST.PrimLit . show) [0..(length enums)-1], scrut_expr)+ AggrType _ (Just (name, EnumType _ enums)) _ -> do+ -- Extract the enumeration field from the aggregation+ let sel_name = mkSelectedName (varToVHDLName scrut) (mkVHDLBasicId name)+ let sel_expr = AST.PrimName sel_name+ return (map (AST.PrimLit . show) [0..(length enums)-1], sel_expr)+ (BuiltinType "Bit") -> do+ let enums = [AST.PrimLit "'1'", AST.PrimLit "'0'"]+ return (enums, scrut_expr)+ (BuiltinType "Bool") -> do+ let enums = [AST.PrimLit "false", AST.PrimLit "true"]+ return (enums, scrut_expr)+ _ -> error $ "\nSelector case on weird scrutinee: " ++ pprString scrut ++ " scrutinee type: " ++ pprString (Id.idType scrut)+ -- Omit first condition, which is the default. Look up each altcon in+ -- the enums list from the HType to find the actual enum value names.+ let altcons = map (\(CoreSyn.DataAlt dc, _, _) -> enums!!(datacon_index scrut dc)) (tail alts)+ -- Compare the (constructor field of the) scrutinee with each of the+ -- alternatives.+ let cond_exprs = map (\x -> cmp AST.:=: x) altcons -- Rotate expressions to the left, so that the expression related to the default case is the last- exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) (alts ++ [alt])+ exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) ((tail alts) ++ [head alts]) return ([mkAltsAssign (Left bndr) cond_exprs exprs], []) -mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement does not have a simple variable as scrutinee"+mkConcSm (_, expr@(CoreSyn.Case _ _ _ _)) = error $ "\nVHDL.mkConcSm: Not in normal form: Case statement does not have a simple variable as scrutinee; expr:\n" ++ pprString expr mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr -----------------------------------------------------------------------------@@ -301,8 +328,8 @@ -- | A function to wrap a builder-like function that expects its arguments to -- be expressions. genExprArgs wrap dst func args = do- args' <- argsToVHDLExprs args- wrap dst func args'+ args' <- argsToVHDLExprs (map fst args)+ wrap dst func (zip args' (map snd args)) -- | Turn the all lefts into VHDL Expressions. argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]@@ -310,7 +337,7 @@ argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr) argToVHDLExpr (Left expr) = MonadState.lift tsType $ do- let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"+ let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen! Expr: \n" ++ show expr ++ "\n has Type:\n" ++ show (CoreUtils.exprType expr) ++ "\n" ty_maybe <- vhdlTy errmsg expr case ty_maybe of Just _ -> do@@ -331,23 +358,23 @@ -- | A function to wrap a builder-like function that expects its arguments to -- be variables.-genVarArgs ::- (dst -> func -> [Var.Var] -> res)- -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)-genVarArgs wrap = genCoreArgs $ \dst func args -> let- args' = map exprToVar args- in- wrap dst func args'+-- genVarArgs ::+-- (dst -> func -> [Var.Var] -> res)+-- -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)+-- genVarArgs wrap = genCoreArgs $ \dst func args -> let+-- args' = map exprToVar args+-- in+-- wrap dst func args' -- | A function to wrap a builder-like function that expects its arguments to -- be core expressions. genCoreArgs :: (dst -> func -> [CoreSyn.CoreExpr] -> res)- -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)+ -> (dst -> func -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> res) genCoreArgs wrap dst func args = wrap dst func args' where -- Check (rather crudely) that all arguments are CoreExprs- args' = case Either.partitionEithers args of + args' = case Either.partitionEithers (map fst args) of (exprargs, []) -> exprargs (exprsargs, rest) -> error $ "\nGenerate.genCoreArgs: expect core expression arguments but found ast exprs:" ++ (show rest) @@ -364,23 +391,22 @@ -- constructor from the AST.Expr type, e.g. AST.And. genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)-genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr-genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2+genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr+genOperator2' op _ f [(arg1,_), (arg2,_)] = return $ op arg1 arg2 -- | Generate a unary operator application genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)-genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr-genOperator1' op _ f [arg] = return $ op arg+genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr+genOperator1' op _ f [(arg,_)] = return $ op arg -- | Generate a unary operator application genNegation :: BuiltinBuilder -genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'-genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr-genNegation' _ f [arg] = do- arg1 <- MonadState.lift tsType $ varToVHDLExpr arg- let ty = Var.varType arg- let (tycon, args) = Type.splitTyConApp ty+genNegation = genNoInsts $ genExprRes genNegation'+genNegation' :: dst -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession AST.Expr+genNegation' _ f [(arg,argType)] = do+ [arg1] <- argsToVHDLExprs [arg]+ let (tycon, args) = Type.splitTyConApp argType let name = Name.getOccString (TyCon.tyConName tycon) case name of "Signed" -> return $ AST.Neg arg1@@ -390,19 +416,19 @@ -- list of expressions (its arguments) genFCall :: Bool -> BuiltinBuilder genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)-genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr+genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr genFCall' switch (Left res) f args = do let fname = varToString f let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res) id <- MonadState.lift tsType $ vectorFunId el_ty fname return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args+ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) (map fst args) genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name genFromSizedWord :: BuiltinBuilder genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'-genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]-genFromSizedWord' (Left res) f args@[arg] =+genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]+genFromSizedWord' (Left res) f args@[(arg,_)] = return [mkUncondAssign (Left res) arg] -- let fname = varToString f -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $@@ -411,8 +437,8 @@ genFromRangedWord :: BuiltinBuilder genFromRangedWord = genNoInsts $ genExprArgs $ genExprRes genFromRangedWord'-genFromRangedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr-genFromRangedWord' (Left res) f [arg] = do {+genFromRangedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr+genFromRangedWord' (Left res) f [(arg,_)] = do { ; let { ty = Var.varType res ; (tycon, args) = Type.splitTyConApp ty ; name = Name.getOccString (TyCon.tyConName tycon)@@ -425,8 +451,8 @@ genResize :: BuiltinBuilder genResize = genNoInsts $ genExprArgs $ genExprRes genResize'-genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr-genResize' (Left res) f [arg] = do {+genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr+genResize' (Left res) f [(arg,_)] = do { ; let { ty = Var.varType res ; (tycon, args) = Type.splitTyConApp ty ; name = Name.getOccString (TyCon.tyConName tycon)@@ -441,8 +467,8 @@ genTimes :: BuiltinBuilder genTimes = genNoInsts $ genExprArgs $ genExprRes genTimes'-genTimes' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr-genTimes' (Left res) f [arg1,arg2] = do {+genTimes' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr+genTimes' (Left res) f [(arg1,_),(arg2,_)] = do { ; let { ty = Var.varType res ; (tycon, args) = Type.splitTyConApp ty ; name = Name.getOccString (TyCon.tyConName tycon)@@ -474,7 +500,7 @@ "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty) "Index" -> do bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)- return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1+ return $ (ceiling (logBase 2 (fromInteger (toInteger (bound))))) let fname = case name of "Signed" -> toSignedId ; "Unsigned" -> toUnsignedId ; "Index" -> toUnsignedId case args of [integer] -> do -- The type and dictionary arguments are removed by genApplication@@ -565,15 +591,16 @@ -} -- | Generate a generate statement for the builtin function "map" genMap :: BuiltinBuilder-genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {+genMap (Left res) f [(Left mapped_f, _), (Left (CoreSyn.Var arg), _)] = do { -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since -- we must index it (which we couldn't if it was a VHDL Expr, since only -- VHDLNames can be indexed). -- Setup the generate scheme ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res+ ; let res_type = (tfvec_elem . Var.varType) res -- TODO: Use something better than varToString- ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))+ ; let { label = mkVHDLExtId ("mapVector" ++ (varToUniqString res)) ; n_id = mkVHDLBasicId "n" ; n_expr = idToVHDLExpr n_id ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))@@ -583,9 +610,9 @@ ; resname = mkIndexedName (varToVHDLName res) n_expr ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f- ; valargs = get_val_args (Var.varType real_f) already_mapped_args- } ;- ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])+ ; valargs = get_val_args (Var.varType real_f) already_mapped_args+ } ; + ; (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr, (tfvec_elem . Var.varType) arg)]) -- Return the generate statement ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used) }@@ -593,11 +620,12 @@ genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name genZipWith :: BuiltinBuilder-genZipWith (Left res) f args@[Left zipped_f, Left (CoreSyn.Var arg1), Left (CoreSyn.Var arg2)] = do {+genZipWith (Left res) f args@[(Left zipped_f, _), (Left (CoreSyn.Var arg1), _), (Left (CoreSyn.Var arg2), _)] = do { -- Setup the generate scheme ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res+ ; let res_type = (tfvec_elem . Var.varType) res -- TODO: Use something better than varToString- ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))+ ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToUniqString res)) ; n_id = mkVHDLBasicId "n" ; n_expr = idToVHDLExpr n_id ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))@@ -610,7 +638,7 @@ ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr } ;- ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr1, Right argexpr2])+ ; (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr1, (tfvec_elem . Var.varType) arg1), (Right argexpr2, (tfvec_elem . Var.varType) arg2)]) -- Return the generate functions ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used) }@@ -622,35 +650,33 @@ genFoldr = genFold False genFold :: Bool -> BuiltinBuilder-genFold left = genVarArgs (genFold' left)--genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])-genFold' left res f args@[folded_f , start ,vec]= do- len <- MonadState.lift tsType $ tfp_to_int (tfvec_len_ty (Var.varType vec))- genFold'' len left res f args+genFold left res f args@[folded_f, start, (vec, vecType)] = do+ len <- MonadState.lift tsType $ tfp_to_int (tfvec_len_ty vecType)+ genFold' len left res f args -genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])+genFold' :: Int -> Bool -> BuiltinBuilder -- Special case for an empty input vector, just assign start to res-genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do- arg <- MonadState.lift tsType $ varToVHDLExpr start+genFold' len left (Left res) _ [_, (start, _), vec] | len == 0 = do+ [arg] <- argsToVHDLExprs [start] return ([mkUncondAssign (Left res) arg], []) -genFold'' len left (Left res) f [folded_f, start, vec] = do+genFold' len left (Left res) f [(Left folded_f,_), (start,startType), (vec,vecType)] = do+ [vecExpr] <- argsToVHDLExprs [vec] -- The vector length --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec -- An expression for len-1 let len_min_expr = (AST.PrimLit $ show (len-1)) -- evec is (TFVec n), so it still needs an element type- let (nvec, _) = Type.splitAppTy (Var.varType vec)+ let (nvec, _) = Type.splitAppTy vecType -- Put the type of the start value in nvec, this will be the type of our -- temporary vector- let tmp_ty = Type.mkAppTy nvec (Var.varType start)+ let tmp_ty = Type.mkAppTy nvec startType let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty -- TODO: Handle Nothing Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty -- Setup the generate scheme- let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))- let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))+ let gen_label = mkVHDLExtId ("foldlVector" ++ (show vecExpr))+ let block_label = mkVHDLExtId ("foldlVector" ++ (varToUniqString res)) let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr else AST.DownRange len_min_expr (AST.PrimLit "0") let gen_scheme = AST.ForGn n_id gen_range@@ -679,7 +705,9 @@ -- Generate parts of the fold genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr]) genFirstCell = do- len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec+ [AST.PrimName vecName, argexpr1] <- argsToVHDLExprs [vec,start]+ let res_type = (tfvec_elem . Var.varType) res+ len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecType let cond_label = mkVHDLExtId "firstcell" -- if n == 0 or n == len-1 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")@@ -687,19 +715,23 @@ -- Output to tmp[current n] let resname = mkIndexedName tmp_name n_cur -- Input from start- argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start+ -- argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start -- Input from vec[current n]- let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur- (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then- [Right argexpr1, Right argexpr2]+ let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName vecName n_cur+ let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs folded_f+ let valargs = get_val_args (Var.varType real_f) already_mapped_args+ (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ ( if left then+ [(Right argexpr1, startType), (Right argexpr2, tfvec_elem vecType)] else- [Right argexpr2, Right argexpr1]- )+ [(Right argexpr2, tfvec_elem vecType), (Right argexpr1, startType)]+ )) -- Return the conditional generate part return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used) genOtherCell = do- len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec+ [AST.PrimName vecName] <- argsToVHDLExprs [vec]+ let res_type = (tfvec_elem . Var.varType) res+ len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecType let cond_label = mkVHDLExtId "othercell" -- if n > 0 or n < len-1 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")@@ -709,33 +741,37 @@ -- Input from tmp[previous n] let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev -- Input from vec[current n]- let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur- (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then- [Right argexpr1, Right argexpr2]+ let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName vecName n_cur+ let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs folded_f+ let valargs = get_val_args (Var.varType real_f) already_mapped_args+ (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ ( if left then+ [(Right argexpr1, startType), (Right argexpr2, tfvec_elem vecType)] else- [Right argexpr2, Right argexpr1]- )+ [(Right argexpr2, tfvec_elem vecType), (Right argexpr1, startType)]+ )) -- Return the conditional generate part return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used) -- | Generate a generate statement for the builtin function "zip" genZip :: BuiltinBuilder-genZip = genNoInsts $ genVarArgs genZip'-genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]-genZip' (Left res) f args@[arg1, arg2] = do {+genZip = genNoInsts genZip'+genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]+genZip' (Left res) f args@[(arg1,_), (arg2,_)] = do { -- Setup the generate scheme ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res+ ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genZip: Invalid result type" (tfvec_elem (Var.varType res))+ ; [AST.PrimName argName1, AST.PrimName argName2] <- argsToVHDLExprs [arg1,arg2] -- TODO: Use something better than varToString- ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))+ ; let { label = mkVHDLExtId ("zipVector" ++ (varToUniqString res)) ; n_id = mkVHDLBasicId "n" ; n_expr = idToVHDLExpr n_id ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1)) ; genScheme = AST.ForGn n_id range ; resname' = mkIndexedName (varToVHDLName res) n_expr- ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr- ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr- } ; - ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res))+ ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName argName1 n_expr+ ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName argName2 n_expr+ ; labels = getFieldLabels res_htype 0+ } ; let { resnameA = mkSelectedName resname' (labels!!0) ; resnameB = mkSelectedName resname' (labels!!1) ; resA_assign = mkUncondAssign (Right resnameA) argexpr1@@ -747,13 +783,15 @@ -- | Generate a generate statement for the builtin function "fst" genFst :: BuiltinBuilder-genFst = genNoInsts $ genVarArgs genFst'-genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]-genFst' (Left res) f args@[arg] = do {- ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)- ; let { argexpr' = varToVHDLName arg- ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!0)- ; assign = mkUncondAssign (Left res) argexprA+genFst = genNoInsts genFst'+genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]+genFst' res f args@[(arg,argType)] = do {+ ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genFst: Invalid argument type" argType+ ; [AST.PrimName argExpr] <- argsToVHDLExprs [arg] + ; let { + ; labels = getFieldLabels arg_htype 0+ ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!0)+ ; assign = mkUncondAssign res argexprA } ; -- Return the generate functions ; return [assign]@@ -761,12 +799,14 @@ -- | Generate a generate statement for the builtin function "snd" genSnd :: BuiltinBuilder-genSnd = genNoInsts $ genVarArgs genSnd'-genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]-genSnd' (Left res) f args@[arg] = do {- ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)- ; let { argexpr' = varToVHDLName arg- ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!1)+genSnd = genNoInsts genSnd'+genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]+genSnd' (Left res) f args@[(arg,argType)] = do {+ ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genSnd: Invalid argument type" argType+ ; [AST.PrimName argExpr] <- argsToVHDLExprs [arg] + ; let { + ; labels = getFieldLabels arg_htype 0+ ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!1) ; assign = mkUncondAssign (Left res) argexprB } ; -- Return the generate functions@@ -775,30 +815,33 @@ -- | Generate a generate statement for the builtin function "unzip" genUnzip :: BuiltinBuilder-genUnzip = genNoInsts $ genVarArgs genUnzip'-genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]-genUnzip' (Left res) f args@[arg] = do- let error_msg = "\nGenerate.genUnzip: Cannot generate unzip call: " ++ pprString res ++ " = " ++ pprString f ++ " " ++ pprString arg- htype <- MonadState.lift tsType $ mkHType error_msg (Var.varType arg)+genUnzip = genNoInsts genUnzip'+genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]+genUnzip' (Left res) f args@[(arg,argType)] = do+ let error_msg = "\nGenerate.genUnzip: Cannot generate unzip call: " ++ pprString res ++ " = " ++ pprString f ++ " " ++ show arg+ htype <- MonadState.lift tsType $ mkHType error_msg argType -- Prepare a unconditional assignment, for the case when either part -- of the unzip is a state variable, which will disappear in the -- resulting VHDL, making the the unzip no longer required. case htype of -- A normal vector containing two-tuples- VecType _ (AggrType _ [_, _]) -> do {+ VecType _ (AggrType _ _ [_, _]) -> do { -- Setup the generate scheme- ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg+ ; len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty argType+ ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genUnzip: Invalid argument type" argType+ ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genUnzip: Invalid result type" (Var.varType res)+ ; [AST.PrimName arg'] <- argsToVHDLExprs [arg] -- TODO: Use something better than varToString- ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))+ ; let { label = mkVHDLExtId ("unzipVector" ++ (varToUniqString res)) ; n_id = mkVHDLBasicId "n" ; n_expr = idToVHDLExpr n_id ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1)) ; genScheme = AST.ForGn n_id range ; resname' = varToVHDLName res- ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr+ ; argexpr' = mkIndexedName arg' n_expr+ ; reslabels = getFieldLabels res_htype 0+ ; arglabels = getFieldLabels arg_htype 0 } ;- ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)- ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg)) ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)@@ -811,21 +854,21 @@ } -- Both elements of the tuple were state, so they've disappeared. No -- need to do anything- VecType _ (AggrType _ []) -> return []+ VecType _ (AggrType _ _ []) -> return [] -- A vector containing aggregates with more than two elements?- VecType _ (AggrType _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg)+ VecType _ (AggrType _ _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ show arg ++ "\nType: " ++ pprString argType -- One of the elements of the tuple was state, so there won't be a -- tuple (record) in the VHDL output. We can just do a plain -- assignment, then. VecType _ _ -> do- argexpr <- MonadState.lift tsType $ varToVHDLExpr arg+ [argexpr] <- argsToVHDLExprs [arg] return [mkUncondAssign (Left res) argexpr]- _ -> error $ "Unzipping a value that is not a vector? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg) ++ "\nhtype: " ++ show htype+ _ -> error $ "Unzipping a value that is not a vector? Value: " ++ show arg ++ "\nType: " ++ pprString argType ++ "\nhtype: " ++ show htype genCopy :: BuiltinBuilder genCopy = genNoInsts genCopy'-genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm]-genCopy' (Left res) f [arg] = do {+genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]+genCopy' (Left res) f [(arg,argType)] = do { ; [arg'] <- argsToVHDLExprs [arg] ; let { resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) arg'] ; out_assign = mkUncondAssign (Left res) resExpr@@ -834,15 +877,16 @@ } genConcat :: BuiltinBuilder-genConcat = genNoInsts $ genVarArgs genConcat'-genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]-genConcat' (Left res) f args@[arg] = do {+genConcat = genNoInsts genConcat'+genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]+genConcat' (Left res) f args@[(arg,argType)] = do { -- Setup the generate scheme- ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg- ; let (_, nvec) = Type.splitAppTy (Var.varType arg)+ ; len1 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty argType+ ; let (_, nvec) = Type.splitAppTy argType ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec+ ; [AST.PrimName argName] <- argsToVHDLExprs [arg] -- TODO: Use something better than varToString- ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))+ ; let { label = mkVHDLExtId ("concatVector" ++ (varToUniqString res)) ; n_id = mkVHDLBasicId "n" ; n_expr = idToVHDLExpr n_id ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)@@ -852,7 +896,7 @@ ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1)) ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1)) ; resname = vecSlice fromRange toRange- ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr+ ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName argName n_expr ; out_assign = mkUncondAssign (Right resname) argexpr } ; -- Return the generate statement@@ -875,18 +919,15 @@ genGenerate = genIterateOrGenerate False genIterateOrGenerate :: Bool -> BuiltinBuilder-genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)--genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])-genIterateOrGenerate' iter (Left res) f args = do+genIterateOrGenerate iter (Left res) f args = do len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)- genIterateOrGenerate'' len iter (Left res) f args+ genIterateOrGenerate' len iter (Left res) f args -genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])+genIterateOrGenerate' :: Int -> Bool -> BuiltinBuilder -- Special case for an empty input vector, just assign start to res-genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])+genIterateOrGenerate' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], []) -genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do+genIterateOrGenerate' len iter (Left res) f [(Left app_f,_), (start,startType)] = do -- The vector length -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res) -- An expression for len-1@@ -900,8 +941,9 @@ -- TODO: Handle Nothing Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty -- Setup the generate scheme- let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))- let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))+ [startExpr] <- argsToVHDLExprs [start]+ let gen_label = mkVHDLExtId ("iterateVector" ++ (show startExpr))+ let block_label = mkVHDLExtId ("iterateVector" ++ (varToUniqString res)) let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr let gen_scheme = AST.ForGn n_id gen_range -- Make the intermediate vector@@ -926,15 +968,18 @@ -- Generate parts of the fold genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr]) genFirstCell = do+ let res_type = (tfvec_elem . Var.varType) res let cond_label = mkVHDLExtId "firstcell" -- if n == 0 or n == len-1 let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0") -- Output to tmp[current n] let resname = mkIndexedName tmp_name n_cur -- Input from start- argexpr <- MonadState.lift tsType $ varToVHDLExpr start+ [argexpr] <- argsToVHDLExprs [start] let startassign = mkUncondAssign (Right resname) argexpr- (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]+ let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs app_f+ let valargs = get_val_args (Var.varType real_f) already_mapped_args+ (app_concsms, used) <- genApplication (Right resname, res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr, startType)]) -- Return the conditional generate part let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then [startassign]@@ -944,6 +989,7 @@ return (gensm, used) genOtherCell = do+ let res_type = (tfvec_elem . Var.varType) res let cond_label = mkVHDLExtId "othercell" -- if n > 0 or n < len-1 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")@@ -951,14 +997,16 @@ let resname = mkIndexedName tmp_name n_cur -- Input from tmp[previous n] let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev- (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]+ let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs app_f+ let valargs = get_val_args (Var.varType real_f) already_mapped_args+ (app_concsms, used) <- genApplication (Right resname, res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr, res_type)]) -- Return the conditional generate part return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used) genBlockRAM :: BuiltinBuilder genBlockRAM = genNoInsts $ genExprArgs genBlockRAM' -genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]+genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(AST.Expr,Type.Type)] -> TranslatorSession [AST.ConcSm] genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do -- Get the ram type let (tup,data_out) = Type.splitAppTy (Var.varType res)@@ -972,10 +1020,10 @@ -- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res) let resname = varToVHDLName res -- let resname = mkSelectedName resname' (reslabels!!0)- let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) rdaddr+ let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) $ fst rdaddr let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int let assign = mkUncondAssign (Right resname) argexpr- let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))+ let block_label = mkVHDLExtId ("blockRAM" ++ (varToUniqString res)) let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm] return [AST.CSBSm block] where@@ -985,21 +1033,24 @@ where proclabel = mkVHDLBasicId "updateRAM" rising_edge = mkVHDLBasicId "rising_edge"- wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) wraddr+ wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) $ fst wraddr ramloc = mkIndexedName (AST.NSimple ram_id) wraddr_int- wform = AST.Wform [AST.WformElem data_in Nothing]+ wform = AST.Wform [AST.WformElem (fst data_in) Nothing] ramassign = AST.SigAssign ramloc wform rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)- statement = AST.IfSm (AST.And rising_edge_clk wrenable) [ramassign] [] Nothing+ statement = AST.IfSm (AST.And rising_edge_clk $ fst wrenable) [ramassign] [] Nothing genSplit :: BuiltinBuilder-genSplit = genNoInsts $ genVarArgs genSplit'+genSplit = genNoInsts genSplit' -genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]-genSplit' (Left res) f args@[vecIn] = do {- ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)- ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vecIn- ; let { block_label = mkVHDLExtId ("split" ++ (varToString vecIn))+genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]+genSplit' (Left res) f args@[(vecIn,vecInType)] = do {+ ; len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecInType+ ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genSplit': Invalid result type" (Var.varType res)+ ; [argExpr] <- argsToVHDLExprs [vecIn]+ ; let { + ; labels = getFieldLabels res_htype 0+ ; block_label = mkVHDLExtId ("split" ++ show argExpr) ; halflen = round ((fromIntegral len) / 2) ; rangeL = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1)) ; rangeR = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))@@ -1017,49 +1068,96 @@ where vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res) (AST.ToRange init last))+ +genSll :: BuiltinBuilder+genSll = genNoInsts $ genExprArgs $ genExprRes genSll'+genSll' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr+genSll' res f [(arg1,_),(arg2,_)] = do {+ ; return $ (AST.Sll arg1 (genExprFCall (mkVHDLBasicId toIntegerId) arg2))+ }++genSra :: BuiltinBuilder+genSra = genNoInsts $ genExprArgs $ genExprRes genSra'+genSra' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr+genSra' res f [(arg1,_),(arg2,_)] = do {+ ; return $ (AST.Sra arg1 (genExprFCall (mkVHDLBasicId toIntegerId) arg2))+ }+ ----------------------------------------------------------------------------- -- Function to generate VHDL for applications ----------------------------------------------------------------------------- genApplication ::- (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?+ (Either CoreSyn.CoreBndr AST.VHDLName, Type.Type) -- ^ Where to store the result? -> CoreSyn.CoreBndr -- ^ The function to apply- -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply+ -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -- ^ The arguments to apply -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The corresponding VHDL concurrent statements and entities -- instantiated.-genApplication dst f args = do+genApplication (dst, dsttype) f args = do nonemptydst <- case dst of- Left bndr -> hasNonEmptyType bndr + Left bndr -> hasNonEmptyType "\nGenerate.genApplication: " bndr Right _ -> return True if nonemptydst then if Var.isGlobalId f then case Var.idDetails f of- IdInfo.DataConWorkId dc -> case dst of+ IdInfo.DataConWorkId dc -> do -- case dst of -- It's a datacon. Create a record from its arguments.- Left bndr -> do+ --Left bndr -> do -- We have the bndr, so we can get at the type- htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)- let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args- case argsNostate of- [arg] -> do+ htype_either <- MonadState.lift tsType $ mkHTypeEither dsttype+ let argsNoState = filter (\(x,y) -> not (either hasStateType (\x -> False) x)) args + argsTransatable <- MonadState.lift tsType $ Monad.filterM (\(x,y) -> canTypeToVHDLType y) argsNoState+ let dcs = datacons_for dsttype+ case (dcs, map fst argsTransatable) of+ -- This is a type with a single datacon and a single+ -- argument, so no record is created (the type of the+ -- binder becomes the type of the single argument).+ ([_], [arg]) -> do [arg'] <- argsToVHDLExprs [arg] return ([mkUncondAssign dst arg'], [])- otherwise ->- case htype of- Right (AggrType _ _) -> do- labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)- args' <- argsToVHDLExprs argsNostate- return (zipWith mkassign labels args', [])- where- mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm- mkassign label arg =- let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in- mkUncondAssign (Right sel_name) arg- _ -> do -- error $ "DIE!"- args' <- argsToVHDLExprs argsNostate- return ([mkUncondAssign dst (head args')], []) - Right _ -> error "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder"+ -- In all other cases, a record type is created.+ _ -> case htype_either of+ Right htype@(AggrType _ etype _) -> do+ let dc_i = datacon_index dsttype dc+ let labels = getFieldLabels htype dc_i+ arg_exprs <- argsToVHDLExprs (map fst argsNoState)+ let (final_labels, final_exprs) = case getConstructorFieldLabel htype of+ -- Only a single constructor+ Nothing -> + (labels, arg_exprs)+ -- Multiple constructors, so assign the+ -- constructor used to the constructor field as+ -- well.+ Just dc_label ->+ let { dc_index = getConstructorIndex (snd $ Maybe.fromJust etype) (varToString f)+ ; dc_expr = AST.PrimLit $ show dc_index + } in (dc_label:labels, dc_expr:arg_exprs)+ return (zipWith mkassign final_labels final_exprs, [])+ where+ mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm+ mkassign label arg =+ let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in+ mkUncondAssign (Right sel_name) arg+ -- Enumeration types have no arguments and are just+ -- simple assignments+ Right (EnumType _ _) ->+ simple_assign+ -- These builtin types are also enumeration types+ Right (BuiltinType tyname) | tyname `elem` ["Bit", "Bool"] ->+ simple_assign+ Right _ -> error $ "Generate.genApplication(DataConWorkId): application does not result in a aggregate type? datacon: " ++ pprString f ++ " Args: " ++ concatMap (\(x,y) -> (either pprString show x) ++ (pprString y)) args+ Left _ -> error $ "Generate.genApplication(DataConWorkId): Unrepresentable result type in datacon application? datacon: " ++ pprString f ++ " Args: " ++ concatMap (\(x,y) -> (either pprString show x) ++ (pprString y)) args+ where+ -- Simple uncoditional assignment, for (built-in)+ -- enumeration types+ simple_assign = do+ expr <- MonadState.lift tsType $ dataconToVHDLExpr dc+ return ([mkUncondAssign dst expr], [])+ -- + -- Right _ -> do+ -- let dcs = datacons_for dsttype+ -- error $ "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder" ++ show dcs IdInfo.DataConWrapId dc -> case dst of -- It's a datacon. Create a record from its arguments. Left bndr ->@@ -1090,7 +1188,7 @@ -- Local binder that references a top level binding. Generate a -- component instantiation. signature <- getEntity f- args' <- argsToVHDLExprs args+ args' <- argsToVHDLExprs (map fst args) let entity_id = ent_id signature -- TODO: Using show here isn't really pretty, but we'll need some -- unique-ish value...@@ -1129,7 +1227,7 @@ -- Local binder that references a top level binding. Generate a -- component instantiation. signature <- getEntity f- args' <- argsToVHDLExprs args+ args' <- argsToVHDLExprs (map fst args) let entity_id = ent_id signature -- TODO: Using show here isn't really pretty, but we'll need some -- unique-ish value...@@ -1145,6 +1243,13 @@ return ([mkUncondAssign dst f'], []) else -- Destination has empty type, don't generate anything return ([], [])+ +canTypeToVHDLType :: Type.Type -> TypeSession Bool+canTypeToVHDLType ty = do+ a <- vhdlTy "Generate.canTypeToVHDLType" ty+ let b = case a of Nothing -> False ; Just _ -> True+ return b + ----------------------------------------------------------------------------- -- Functions to generate functions dealing with vectors. -----------------------------------------------------------------------------@@ -1198,8 +1303,8 @@ , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[])) , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[])) , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))- , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))- , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))+ , (shiftIntoLId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))+ , (shiftIntoRId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId])) , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], [])) , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId])) , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))@@ -1427,7 +1532,7 @@ lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))- shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,+ shiftlSpec = AST.Function (mkVHDLExtId shiftIntoLId) [AST.IfaceVarDec vecPar vectorTM, AST.IfaceVarDec aPar elemTM ] vectorTM -- variable res : fsvec_x (0 to vec'length-1); shiftlVar = @@ -1445,7 +1550,7 @@ (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId)) [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])) shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) - shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,+ shiftrSpec = AST.Function (mkVHDLExtId shiftIntoRId) [AST.IfaceVarDec vecPar vectorTM, AST.IfaceVarDec aPar elemTM ] vectorTM -- variable res : fsvec_x (0 to vec'length-1); shiftrVar = @@ -1553,7 +1658,7 @@ type BuiltinBuilder = (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type -> CoreSyn.CoreBndr -- ^ The function called- -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and+ -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -- ^ The value arguments passed (excluding type and -- dictionary arguments). -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The corresponding VHDL concurrent statements and entities@@ -1585,8 +1690,8 @@ , (foldrId , (3, genFoldr ) ) , (zipId , (2, genZip ) ) , (unzipId , (1, genUnzip ) )- , (shiftlId , (2, genFCall False ) )- , (shiftrId , (2, genFCall False ) )+ , (shiftIntoLId , (2, genFCall False ) )+ , (shiftIntoRId , (2, genFCall False ) ) , (rotlId , (1, genFCall False ) ) , (rotrId , (1, genFCall False ) ) , (concatId , (1, genConcat ) )@@ -1629,6 +1734,9 @@ , (sndId , (1, genSnd ) ) , (blockRAMId , (5, genBlockRAM ) ) , (splitId , (1, genSplit ) )+ , (xorId , (2, genOperator2 AST.Xor ) )+ , (shiftLId , (2, genSll ) )+ , (shiftRId , (2, genSra ) ) --, (tfvecId , (1, genTFVec ) ) , (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name")) ]
CLasH/VHDL/Testbench.hs view
@@ -130,7 +130,7 @@ createStimulans expr cycl = do -- There must be a let at top level - expr <- normalizeExpr ("test input #" ++ show cycl) expr+ expr <- normalizeExpr ("test input #" ++ show cycl) transforms expr -- Split the normalized expression. It can't have a function type, so match -- an empty list of argument binders let ([], binds, res) = splitNormalized expr@@ -170,4 +170,4 @@ writeOut outSig suffix = genExprPCall2 writeId (AST.PrimName $ AST.NSimple outputId)- ((genExprFCall showId (AST.PrimName $ AST.NSimple outSig)) AST.:&: suffix)+ ((genExprFCall2 showId (AST.PrimName $ AST.NSimple outSig, AST.PrimLit "false")) AST.:&: suffix)
CLasH/VHDL/VHDLTools.hs view
@@ -162,6 +162,11 @@ -- Turn a Core expression into an AST expression exprToVHDLExpr core = varToVHDLExpr (exprToVar core) +-- Turn a String into a VHDL expr containing an id+stringToVHDLExpr :: String -> AST.Expr+stringToVHDLExpr = idToVHDLExpr . mkVHDLExtId ++ -- Turn a alternative constructor into an AST expression. For -- dataconstructors, this is only the constructor itself, not any arguments it -- has. Should not be called with a DEFAULT constructor.@@ -187,7 +192,7 @@ let existing_ty = Monad.liftM (fmap fst) $ Map.lookup htype typemap case existing_ty of Just ty -> do- let lit = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname+ let lit = AST.PrimLit $ show $ getConstructorIndex htype $ Name.getOccString dcname return lit Nothing -> error $ "\nVHDLTools.dataconToVHDLExpr: Trying to make value for non-representable DataCon: " ++ pprString dc -- Error when constructing htype@@ -201,10 +206,7 @@ varToVHDLId :: CoreSyn.CoreBndr -> AST.VHDLId-varToVHDLId var = mkVHDLExtId (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))- where- lowers :: String -> Int- lowers xs = length [x | x <- xs, Char.isLower x]+varToVHDLId var = mkVHDLExtId $ varToUniqString var -- Creates a VHDL Name from a binder varToVHDLName ::@@ -218,6 +220,14 @@ -> String varToString = OccName.occNameString . Name.nameOccName . Var.varName +varToUniqString ::+ CoreSyn.CoreBndr+ -> String+varToUniqString var = (varToString var ++ varToStringUniq var ++ show (lowers $ varToStringUniq var))+ where+ lowers :: String -> Int+ lowers xs = length [x | x <- xs, Char.isLower x]+ -- Get the string version a Var's unique varToStringUniq :: Var.Var -> String varToStringUniq = show . Var.varUnique@@ -251,12 +261,18 @@ -- basic ids. -- Use extended Ids for any values that are taken from the source file. mkVHDLExtId :: String -> AST.VHDLId-mkVHDLExtId s = - AST.unsafeVHDLExtId $ strip_invalid s+mkVHDLExtId s =+ (AST.unsafeVHDLBasicId . zEncodeString . strip_multiscore . strip_leading . strip_invalid) s where -- Allowed characters, taken from ForSyde's mkVHDLExtId allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&'()*+,./:;<=>_|!$%@?[]^`{}~-" strip_invalid = filter (`elem` allowed)+ strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")+ strip_multiscore = concatMap (\cs -> + case cs of + ('_':_) -> "_"+ _ -> cs+ ) . List.group -- Create a record field selector that selects the given label from the record -- stored in the given binder.@@ -341,7 +357,10 @@ return $ Right $ SizedIType len "Index" -> do bound <- tfp_to_int (ranged_word_bound_ty ty)- return $ Right $ RangedWType bound+ -- Upperbound is exclusive, hence the -1+ return $ Right $ RangedWType (bound - 1)+ "()" -> do+ return $ Right UnitType otherwise -> mkTyConHType tycon args Nothing -> return $ Left $ "\nVHDLTools.mkHTypeEither': Do not know what to do with type: " ++ pprString ty@@ -351,42 +370,62 @@ case TyCon.tyConDataCons tycon of -- Not an algebraic type [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon- [dc] -> do- let arg_tys = DataCon.dataConRepArgTys dc- let real_arg_tys = map (CoreSubst.substTy subst) arg_tys- let real_arg_tys_nostate = filter (\x -> not (isStateType x)) real_arg_tys- elem_htys_either <- mapM mkHTypeEither real_arg_tys_nostate- case Either.partitionEithers elem_htys_either of- ([], [elem_hty]) ->- return $ Right elem_hty- -- No errors in element types- ([], elem_htys) ->- return $ Right $ AggrType (nameToString (TyCon.tyConName tycon)) elem_htys- -- There were errors in element types- (errors, _) -> return $ Left $- "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"- ++ (concat errors) dcs -> do- let arg_tys = concatMap DataCon.dataConRepArgTys dcs- let real_arg_tys = map (CoreSubst.substTy subst) arg_tys- case real_arg_tys of- [] ->- return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)- xs -> return $ Left $- "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"+ let arg_tyss = map DataCon.dataConRepArgTys dcs+ let enum_ty = EnumType name (map (nameToString . DataCon.dataConName) dcs)+ case (concat arg_tyss) of+ -- No arguments, this is just an enumeration type+ [] -> return (Right enum_ty)+ -- At least one argument, this becomes an aggregate type+ _ -> do+ -- Resolve any type arguments to this type+ let real_arg_tyss = map (map (CoreSubst.substTy subst)) arg_tyss+ -- Remove any state type fields+ let real_arg_tyss_nostate = map (filter (\x -> not (isStateType x))) real_arg_tyss+ elem_htyss_either <- mapM (mapM mkHTypeEither) real_arg_tyss_nostate+ let (errors, elem_htyss) = unzip (map Either.partitionEithers elem_htyss_either)+ case (all null errors) of+ True -> case (dcs,filter (\x -> x /= UnitType && x /= StateType) $ concat elem_htyss) of+ -- A single constructor with a single (non-state) field?+ ([dc], [elem_hty]) -> return $ Right elem_hty+ -- If we get here, then all of the argument types were state+ -- types (we check for enumeration types at the top). Not+ -- sure how to handle this, so error out for now.+ (_, []) -> return $ Right StateType --error $ "VHDLTools.mkTyConHType: ADT with only State elements (or something like that?) Dunno how to handle this yet. Tycon: " ++ pprString tycon ++ " Arguments: " ++ pprString args+ -- A full ADT (with multiple fields and one or multiple+ -- constructors).+ (_, elem_htys) -> do+ let (_, fieldss) = List.mapAccumL (List.mapAccumL label_field) labels elem_htyss+ -- Only put in an enumeration as part of the aggregation+ -- when there are multiple datacons+ let enum_ty_part = case dcs of+ [dc] -> Nothing+ _ -> Just ("constructor", enum_ty)+ -- Create the AggrType HType+ return $ Right $ AggrType name enum_ty_part fieldss+ -- There were errors in element types+ False -> return $ Left $+ "\nVHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n" + ++ (concat $ concat errors) where+ name = (nameToString (TyCon.tyConName tycon)) tyvars = TyCon.tyConTyVars tycon subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)+ -- Label a field by taking the first available label and returning+ -- the rest.+ label_field :: [String] -> HType -> ([String], (String, HType))+ label_field (l:ls) htype = (ls, (l, htype))+ labels = map (:[]) ['A'..'Z'] --- Translate a Haskell type to a VHDL type, generating a new type if needed.--- Returns an error value, using the given message, when no type could be--- created. Returns Nothing when the type is valid, but empty. vhdlTy :: (TypedThing t, Outputable.Outputable t) => String -> t -> TypeSession (Maybe AST.TypeMark) vhdlTy msg ty = do htype <- mkHType msg ty vhdlTyMaybe htype +-- | Translate a Haskell type to a VHDL type, generating a new type if needed.+-- Returns an error value, using the given message, when no type could be+-- created. Returns Nothing when the type is valid, but empty. vhdlTyMaybe :: HType -> TypeSession (Maybe AST.TypeMark) vhdlTyMaybe htype = do typemap <- MonadState.get tsTypes@@ -412,7 +451,8 @@ -- State types don't generate VHDL construct_vhdl_ty htype = case htype of- StateType -> return Nothing+ StateType -> return Nothing+ UnitType -> return Nothing (SizedWType w) -> mkUnsignedTy w (SizedIType i) -> mkSignedTy i (RangedWType u) -> mkNaturalTy 0 u@@ -424,30 +464,57 @@ mkTyconTy :: HType -> TypeSession TypeMapRec mkTyconTy htype = case htype of- (AggrType tycon args) -> do- elemTysMaybe <- mapM vhdlTyMaybe args- case Maybe.catMaybes elemTysMaybe of- [] -> -- No non-empty members+ (AggrType name enum_field_maybe fieldss) -> do+ let (labelss, elem_htypess) = unzip (map unzip fieldss)+ elemTyMaybess <- mapM (mapM vhdlTyMaybe) elem_htypess+ let elem_tyss = map Maybe.catMaybes elemTyMaybess+ case concat elem_tyss of+ [] -> -- No non-empty fields return Nothing- elem_tys -> do- let elems = zipWith AST.ElementDec recordlabels elem_tys - let elem_names = concatMap prettyShow elem_tys- let ty_id = mkVHDLExtId $ tycon ++ elem_names- let ty_def = AST.TDR $ AST.RecordTypeDef elems- let tupshow = mkTupleShow elem_tys ty_id- MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, tupshow)+ _ -> do+ let reclabelss = map (map mkVHDLBasicId) labelss+ let elemss = zipWith (zipWith AST.ElementDec) reclabelss elem_tyss+ let elem_names = concatMap (concatMap prettyShow) elem_tyss+ let ty_id = mkVHDLExtId $ name ++ elem_names+ -- Find out if we need to add an extra field at the start of+ -- the record type containing the constructor (only needed+ -- when there's more than one constructor).+ enum_ty_maybe <- case enum_field_maybe of+ Nothing -> return Nothing+ Just (_, enum_htype) -> do+ enum_ty_maybe' <- vhdlTyMaybe enum_htype+ case enum_ty_maybe' of+ Nothing -> error $ "Couldn't translate enumeration type part of AggrType: " ++ show htype+ -- Note that the first Just means the type is+ -- translateable, while the second Just means that there+ -- is a enum_ty at all (e.g., there's multiple+ -- constructors).+ Just enum_ty -> return $ Just enum_ty+ -- Create an record field declaration for the first+ -- constructor field, if needed.+ enum_dec_maybe <- case enum_field_maybe of+ Nothing -> return $ Nothing+ Just (enum_name, enum_htype) -> do+ enum_vhdl_ty_maybe <- vhdlTyMaybe enum_htype+ let enum_vhdl_ty = Maybe.fromMaybe (error $ "\nVHDLTools.mkTyconTy: Enumeration field should not have empty type: " ++ show enum_htype) enum_vhdl_ty_maybe+ return $ Just $ AST.ElementDec (mkVHDLBasicId enum_name) enum_vhdl_ty+ -- Turn the maybe into a list, so we can prepend it.+ let enum_decs = Maybe.maybeToList enum_dec_maybe+ let enum_tys = Maybe.maybeToList enum_ty_maybe+ let ty_def = AST.TDR $ AST.RecordTypeDef (enum_decs ++ concat elemss)+ let aggrshow = case enum_field_maybe of + Nothing -> mkTupleShow (enum_tys ++ concat elem_tyss) ty_id+ Just (conLbl, EnumType tycon dcs) -> mkAdtShow conLbl dcs (map (map fst) fieldss) ty_id+ MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, aggrshow) return $ Just (ty_id, Just $ Left ty_def) (EnumType tycon dcs) -> do- let elems = map mkVHDLExtId dcs let ty_id = mkVHDLExtId tycon- let ty_def = AST.TDE $ AST.EnumTypeDef elems- let enumShow = mkEnumShow elems ty_id+ let range = AST.SubTypeRange (AST.PrimLit "0") (AST.PrimLit $ show ((length dcs) - 1))+ let ty_def = AST.TDI $ AST.IntegerTypeDef range+ let enumShow = mkEnumShow dcs ty_id MonadState.modify tsTypeFuns $ Map.insert (htype, showIdString) (showId, enumShow) return $ Just (ty_id, Just $ Left ty_def) otherwise -> error $ "\nVHDLTools.mkTyconTy: Called for HType that is neiter a AggrType or EnumType: " ++ show htype- where- -- Generate a bunch of labels for fields of a record- recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z'] -- | Create a VHDL vector type mkVectorTy ::@@ -488,7 +555,7 @@ mkNaturalTy min_bound max_bound = do let bitsize = floor (logBase 2 (fromInteger (toInteger max_bound))) let ty_id = mkVHDLExtId $ "natural_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)- let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit $ show min_bound) (AST.PrimLit $ show bitsize)]+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show bitsize) (AST.PrimLit $ show min_bound)] let ty_def = AST.SubtypeIn unsignedTM (Just range) return (Just (ty_id, Just $ Right ty_def)) @@ -496,8 +563,8 @@ Int -- ^ Haskell type of the unsigned integer -> TypeSession TypeMapRec mkUnsignedTy size = do- let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)- let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]+ let ty_id = mkVHDLExtId $ "unsigned_" ++ show size+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")] let ty_def = AST.SubtypeIn unsignedTM (Just range) return (Just (ty_id, Just $ Right ty_def)) @@ -505,30 +572,56 @@ Int -- ^ Haskell type of the signed integer -> TypeSession TypeMapRec mkSignedTy size = do- let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)- let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]+ let ty_id = mkVHDLExtId $ "signed_" ++ show size+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.DownRange (AST.PrimLit $ show (size - 1)) (AST.PrimLit "0")] let ty_def = AST.SubtypeIn signedTM (Just range) return (Just (ty_id, Just $ Right ty_def)) --- Finds the field labels for VHDL type generated for the given Core type,--- which must result in a record type.-getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]-getFieldLabels ty = do- -- Ensure that the type is generated (but throw away it's VHDLId)- let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." - vhdlTy error_msg ty- -- Get the types map, lookup and unpack the VHDL TypeDef- types <- MonadState.get tsTypes- -- Assume the type for which we want labels is really translatable- htype <- mkHType error_msg ty- case Map.lookup htype types of- Nothing -> error $ "\nVHDLTools.getFieldLabels: Type not found? This should not happen!\nLooking for type: " ++ (pprString ty) ++ "\nhtype: " ++ (show htype) - Just Nothing -> return [] -- The type is empty- Just (Just (_, Just (Left (AST.TDR (AST.RecordTypeDef elems))))) -> return $ map (\(AST.ElementDec id _) -> id) elems- Just (Just (_, Just vty)) -> error $ "\nVHDLTools.getFieldLabels: Type not a record type? This should not happen!\nLooking for type: " ++ pprString (ty) ++ "\nhtype: " ++ (show htype) ++ "\nFound type: " ++ (show vty)- +-- Finds the field labels and types for aggregation HType. Returns an+-- error on other types.+getFields ::+ HType -- ^ The HType to get fields for+ -> Int -- ^ The constructor to get fields for (e.g., 0+ -- for the first constructor, etc.)+ -> [(String, HType)] -- ^ A list of fields, with their name and type+getFields htype dc_i = case htype of+ (AggrType name _ fieldss) + | dc_i >= 0 && dc_i < length fieldss -> fieldss!!dc_i+ | otherwise -> error $ "VHDLTool.getFields: Invalid constructor index: " ++ (show dc_i) ++ ". No such constructor in HType: " ++ (show htype)+ _ -> error $ "VHDLTool.getFields: Can't get fields from non-aggregate HType: " ++ show htype++-- Finds the field labels for an aggregation type, as VHDLIds.+getFieldLabels ::+ HType -- ^ The HType to get field labels for+ -> Int -- ^ The constructor to get fields for (e.g., 0+ -- for the first constructor, etc.)+ -> [AST.VHDLId] -- ^ The labels+getFieldLabels htype dc_i = ((map mkVHDLBasicId) . (map fst)) (getFields htype dc_i)++-- Finds the field label for the constructor field, if any.+getConstructorFieldLabel ::+ HType+ -> Maybe AST.VHDLId+getConstructorFieldLabel (AggrType _ (Just con) _) =+ Just $ mkVHDLBasicId (fst con)+getConstructorFieldLabel (AggrType _ Nothing _) =+ Nothing+getConstructorFieldLabel htype =+ error $ "Can't get constructor field label from non-aggregate HType: " ++ show htype+++getConstructorIndex ::+ HType ->+ String ->+ Int+getConstructorIndex (EnumType etype cons) dc = case List.elemIndex dc cons of+ Just (index) -> index+ Nothing -> error $ "VHDLTools.getConstructorIndex: constructor: " ++ show dc ++ " is not part of type: " ++ show etype ++ ", which only has constructors: " ++ show cons+getConstructorIndex htype _ = error $ "VHDLTools.getConstructorIndex: Can't get constructor index for non-Enum type: " ++ show htype++ mktydecl :: (AST.VHDLId, Maybe (Either AST.TypeDef AST.SubtypeIn)) -> Maybe AST.PackageDecItem-mytydecl (_, Nothing) = Nothing+mktydecl (_, Nothing) = Nothing mktydecl (ty_id, Just (Left ty_def)) = Just $ AST.PDITD $ AST.TypeDec ty_id ty_def mktydecl (ty_id, Just (Right ty_def)) = Just $ AST.PDISD $ AST.SubtypeDec ty_id ty_def @@ -539,7 +632,8 @@ mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr] where tupPar = AST.unsafeVHDLBasicId "tup"- showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM] stringTM+ parenPar = AST.unsafeVHDLBasicId "paren"+ showSpec = AST.Function showId [AST.IfaceVarDec tupPar tupleTM, AST.IfaceVarDec parenPar booleanTM] stringTM showExpr = AST.ReturnSm (Just $ AST.PrimLit "'('" AST.:&: showMiddle AST.:&: AST.PrimLit "')'") where@@ -547,25 +641,55 @@ AST.PrimLit "''" else foldr1 (\e1 e2 -> e1 AST.:&: AST.PrimLit "','" AST.:&: e2) $- map ((genExprFCall showId).- AST.PrimName .- AST.NSelected .- (AST.NSimple tupPar AST.:.:).- tupVHDLSuffix)+ map ((genExprFCall2 showId) . (\x -> (selectedName tupPar x, AST.PrimLit "false"))) (take tupSize recordlabels) recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z'] tupSize = length elemTMs+ selectedName par = (AST.PrimName . AST.NSelected . (AST.NSimple par AST.:.:) . tupVHDLSuffix) +mkAdtShow ::+ String+ -> [String] -- Constructors+ -> [[String]] -- Fields for every constructor+ -> AST.TypeMark+ -> AST.SubProgBody+mkAdtShow conLbl conIds elemIdss adtTM = AST.SubProgBody showSpec [] [showExpr]+ where + adtPar = AST.unsafeVHDLBasicId "adt"+ parenPar = AST.unsafeVHDLBasicId "paren"+ showSpec = AST.Function showId [AST.IfaceVarDec adtPar adtTM, AST.IfaceVarDec parenPar booleanTM] stringTM+ showExpr = AST.CaseSm ((selectedName adtPar) (mkVHDLBasicId conLbl))+ [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] (+ if (null (elemIdss!!x)) then+ [AST.ReturnSm (Just $ ((genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "false")) $ mkVHDLBasicId conLbl) AST.:&: showFields x)]+ else+ [addParens (((genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "false")) $ mkVHDLBasicId conLbl) AST.:&: showFields x)]+ ) | x <- [0..(length conIds) -1]]+ showFields i = if (null (elemIdss!!i)) then+ AST.PrimLit "\"\""+ else+ foldr1 (\e1 e2 -> e1 AST.:&: e2) $+ map ((AST.PrimLit "' '" AST.:&:) . (genExprFCall2 showId) . (\x -> (selectedName adtPar x, AST.PrimLit "true")))+ (map mkVHDLBasicId (elemIdss!!i))+ selectedName par = (AST.PrimName . AST.NSelected . (AST.NSimple par AST.:.:) . tupVHDLSuffix)+ addParens :: AST.Expr -> AST.SeqSm+ addParens k = AST.IfSm (AST.PrimName (AST.NSimple parenPar))+ [AST.ReturnSm (Just (AST.PrimLit "'('" AST.:&: k AST.:&: AST.PrimLit "')'" ))]+ []+ (Just $ AST.Else [AST.ReturnSm (Just k)])+ mkEnumShow ::- [AST.VHDLId]+ [String] -> AST.TypeMark -> AST.SubProgBody mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]- where- enumPar = AST.unsafeVHDLBasicId "enum"- showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM- showExpr = AST.ReturnSm (Just $- AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))+ where + enumPar = AST.unsafeVHDLBasicId "enum"+ parenPar = AST.unsafeVHDLBasicId "paren"+ showSpec = AST.Function showId [AST.IfaceVarDec enumPar enumTM, AST.IfaceVarDec parenPar booleanTM] stringTM+ showExpr = AST.CaseSm (AST.PrimName $ AST.NSimple enumPar)+ [AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit $ show x] [AST.ReturnSm (Just $ AST.PrimLit $ '"':(elemIds!!x)++['"'])] | x <- [0..(length elemIds) -1]]+ mkVectorShow :: AST.TypeMark -- ^ elemtype@@ -579,6 +703,7 @@ where vecPar = AST.unsafeVHDLBasicId "vec" resId = AST.unsafeVHDLBasicId "res"+ parenPar = AST.unsafeVHDLBasicId "paren" headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM -- return vec(0); headExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName @@ -605,8 +730,8 @@ AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: AST.PrimLit "1")) tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)- showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM] stringTM- doShowId = AST.unsafeVHDLExtId "doshow"+ showSpec = AST.Function showId [AST.IfaceVarDec vecPar vectorTM, AST.IfaceVarDec parenPar booleanTM] stringTM+ doShowId = AST.unsafeVHDLBasicId "doshow" doShowDef = AST.SubProgBody doShowSpec [] [doShowRet] where doShowSpec = AST.Function doShowId [AST.IfaceVarDec vecPar vectorTM] stringTM@@ -623,12 +748,12 @@ [AST.ReturnSm (Just $ AST.PrimLit "\"\"")], AST.CaseSmAlt [AST.ChoiceE $ AST.PrimLit "1"] [AST.ReturnSm (Just $ - genExprFCall showId - (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) )],+ genExprFCall2 showId + (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar),AST.PrimLit "false") )], AST.CaseSmAlt [AST.Others] [AST.ReturnSm (Just $ - genExprFCall showId - (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar)) AST.:&:+ genExprFCall2 showId + (genExprFCall (mkVHDLExtId headId) (AST.PrimName $ AST.NSimple vecPar), AST.PrimLit "false") AST.:&: AST.PrimLit "','" AST.:&: genExprFCall doShowId (genExprFCall (mkVHDLExtId tailId) (AST.PrimName $ AST.NSimple vecPar)) ) ]]@@ -649,26 +774,27 @@ boolPar = AST.unsafeVHDLBasicId "b" signedPar = AST.unsafeVHDLBasicId "sint" unsignedPar = AST.unsafeVHDLBasicId "uint"+ parenPar = AST.unsafeVHDLBasicId "paren" -- naturalPar = AST.unsafeVHDLBasicId "nat"- showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM] stringTM+ showBitSpec = AST.Function showId [AST.IfaceVarDec bitPar std_logicTM, AST.IfaceVarDec parenPar booleanTM] stringTM -- if s = '1' then return "'1'" else return "'0'" showBitExpr = AST.IfSm (AST.PrimName (AST.NSimple bitPar) AST.:=: AST.PrimLit "'1'") [AST.ReturnSm (Just $ AST.PrimLit "\"High\"")] [] (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"Low\"")])- showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM] stringTM+ showBoolSpec = AST.Function showId [AST.IfaceVarDec boolPar booleanTM, AST.IfaceVarDec parenPar booleanTM] stringTM -- if b then return "True" else return "False" showBoolExpr = AST.IfSm (AST.PrimName (AST.NSimple boolPar)) [AST.ReturnSm (Just $ AST.PrimLit "\"True\"")] [] (Just $ AST.Else [AST.ReturnSm (Just $ AST.PrimLit "\"False\"")])- showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM] stringTM+ showSingedSpec = AST.Function showId [AST.IfaceVarDec signedPar signedTM, AST.IfaceVarDec parenPar booleanTM] stringTM showSignedExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [signToInt]) Nothing ) where signToInt = genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple signedPar)- showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM] stringTM+ showUnsignedSpec = AST.Function showId [AST.IfaceVarDec unsignedPar unsignedTM, AST.IfaceVarDec parenPar booleanTM] stringTM showUnsignedExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerId) (AST.NIndexed $ AST.IndexedName (AST.NSimple imageId) [unsignToInt]) Nothing )@@ -685,6 +811,11 @@ AST.PrimFCall $ AST.FCall (AST.NSimple fName) $ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [args] +genExprFCall2 :: AST.VHDLId -> (AST.Expr, AST.Expr) -> AST.Expr+genExprFCall2 fName (arg1, arg2) = + AST.PrimFCall $ AST.FCall (AST.NSimple fName) $+ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) [arg1,arg2] + genExprPCall2 :: AST.VHDLId -> AST.Expr -> AST.Expr -> AST.SeqSm genExprPCall2 entid arg1 arg2 = AST.ProcCall (AST.NSimple entid) $@@ -700,5 +831,5 @@ -- | Does the given thing have a non-empty type? hasNonEmptyType :: (TypedThing t, Outputable.Outputable t) => - t -> TranslatorSession Bool-hasNonEmptyType thing = MonadState.lift tsType $ isJustM (vhdlTy "hasNonEmptyType: Non representable type?" thing)+ String -> t -> TranslatorSession Bool+hasNonEmptyType errMsg thing = MonadState.lift tsType $ isJustM (vhdlTy (errMsg ++ "\nVHDLTools.hasNonEmptyType: Non representable type?") thing)
Data/Param/Index.hs view
@@ -8,48 +8,48 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift(..)) -import Data.Bits+import qualified Data.Bits as B import Types import Types.Data.Num.Decimal.Literals.TH import Data.Param.Integer -instance NaturalT nT => Lift (Index nT) where+instance PositiveT nT => Lift (Index nT) where lift (Index i) = sigE [| (Index i) |] (decIndexT (fromIntegerT (undefined :: nT))) decIndexT :: Integer -> Q Type decIndexT n = appT (conT (''Index)) (decLiteralT n) fromNaturalT :: ( NaturalT n- , NaturalT upper- , (n :<=: upper) ~ True ) => n -> Index upper+ , PositiveT upper+ , (n :<: upper) ~ True ) => n -> Index upper fromNaturalT x = Index (fromIntegerT x) fromUnsigned ::- ( NaturalT nT+ ( PositiveT nT , Integral (Unsigned nT)- ) => Unsigned nT -> Index ((Pow2 nT) :-: D1)+ ) => Unsigned nT -> Index (Pow2 nT) fromUnsigned unsigned = Index (toInteger unsigned) rangeT :: Index nT -> nT rangeT _ = undefined -instance NaturalT nT => Eq (Index nT) where+instance PositiveT nT => Eq (Index nT) where (Index x) == (Index y) = x == y (Index x) /= (Index y) = x /= y -instance NaturalT nT => Show (Index nT) where+instance PositiveT nT => Show (Index nT) where showsPrec prec n = showsPrec prec $ toInteger n -instance NaturalT nT => Ord (Index nT) where+instance PositiveT nT => Ord (Index nT) where a `compare` b = toInteger a `compare` toInteger b -instance NaturalT nT => Bounded (Index nT) where+instance PositiveT nT => Bounded (Index nT) where minBound = 0- maxBound = Index (fromIntegerT (undefined :: nT))+ maxBound = Index $ (fromIntegerT (undefined :: nT)) - 1 -instance NaturalT nT => Enum (Index nT) where+instance PositiveT nT => Enum (Index nT) where succ x | x == maxBound = error $ "Enum.succ{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to take `succ' of maxBound" | otherwise = x + 1@@ -72,7 +72,7 @@ | otherwise = fromInteger $ toInteger x -instance NaturalT nT => Num (Index nT) where+instance PositiveT nT => Num (Index nT) where (Index a) + (Index b) = fromInteger $ a + b (Index a) * (Index b) =@@ -80,8 +80,8 @@ (Index a) - (Index b) = fromInteger $ a - b fromInteger n- | n > fromIntegerT (undefined :: nT) =- error $ "Num.fromInteger{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to make Index larger than " ++ show (fromIntegerT (undefined :: nT)) ++ ", n: " ++ show n+ | n >= fromIntegerT (undefined :: nT) =+ error $ "Num.fromInteger{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to make Index larger than " ++ show (fromIntegerT (undefined :: nT) - 1) ++ ", n: " ++ show n fromInteger n | n < 0 = error $ "Num.fromInteger{Index " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to make Index smaller than 0, n: " ++ show n@@ -94,10 +94,10 @@ | otherwise = 1 -instance NaturalT nT => Real (Index nT) where+instance PositiveT nT => Real (Index nT) where toRational n = toRational $ toInteger n -instance NaturalT nT => Integral (Index nT) where+instance PositiveT nT => Integral (Index nT) where a `quotRem` b = let (quot, rem) = toInteger a `quotRem` toInteger b in (fromInteger quot, fromInteger rem)
Data/Param/Integer.hs view
@@ -2,12 +2,18 @@ ( Signed(..) , Unsigned(..) , Index (..)+ , HWBits(..) ) where import Types+import qualified Data.Bits as B newtype (NaturalT nT) => Signed nT = Signed Integer newtype (NaturalT nT) => Unsigned nT = Unsigned Integer -newtype (NaturalT upper) => Index upper = Index Integer+newtype (PositiveT upper) => Index upper = Index Integer++class (B.Bits a) => HWBits a where+ shiftL :: a -> a -> a+ shiftR :: a -> a -> a
Data/Param/Signed.hs view
@@ -1,12 +1,12 @@ {-# LANGUAGE TypeFamilies, TypeOperators, ScopedTypeVariables, FlexibleInstances, TemplateHaskell, Rank2Types, FlexibleContexts #-} module Data.Param.Signed ( Signed- , resize+ , resizeSigned ) where import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift(..))-import Data.Bits+import qualified Data.Bits as B import Types import Types.Data.Num.Decimal.Literals.TH @@ -18,8 +18,8 @@ decSignedT :: Integer -> Q Type decSignedT n = appT (conT (''Signed)) (decLiteralT n) -resize :: (NaturalT nT, NaturalT nT') => Signed nT -> Signed nT'-resize a = fromInteger (toInteger a)+resizeSigned :: (NaturalT nT, NaturalT nT') => Signed nT -> Signed nT'+resizeSigned a = fromInteger (toInteger a) sizeT :: Signed nT -> nT@@ -28,7 +28,7 @@ mask :: forall nT . NaturalT nT => nT -> Integer-mask _ = bit (fromIntegerT (undefined :: nT)) - 1+mask _ = B.bit (fromIntegerT (undefined :: nT)) - 1 signBit :: forall nT . NaturalT nT => nT@@ -39,7 +39,7 @@ => Signed nT -> Bool isNegative (Signed x) =- testBit x $ signBit (undefined :: nT)+ B.testBit x $ signBit (undefined :: nT) instance NaturalT nT => Eq (Signed nT) where (Signed x) == (Signed y) = x == y@@ -58,8 +58,8 @@ a `compare` b = toInteger a `compare` toInteger b instance NaturalT nT => Bounded (Signed nT) where- minBound = Signed $ negate $ 1 `shiftL` (fromIntegerT (undefined :: nT) - 1)- maxBound = Signed $ (1 `shiftL` (fromIntegerT (undefined :: nT) - 1)) - 1+ minBound = Signed $ negate $ 1 `B.shiftL` (fromIntegerT (undefined :: nT) - 1)+ maxBound = Signed $ (1 `B.shiftL` (fromIntegerT (undefined :: nT) - 1)) - 1 instance NaturalT nT => Enum (Signed nT) where succ x@@ -91,13 +91,13 @@ (Signed a) * (Signed b) = fromInteger $ a * b negate (Signed n) =- fromInteger $ (n `xor` mask (undefined :: nT)) + 1+ fromInteger $ (n `B.xor` mask (undefined :: nT)) + 1 a - b = a + (negate b) fromInteger n | n > 0 =- Signed $ n .&. mask (undefined :: nT)+ Signed $ n B..&. mask (undefined :: nT) fromInteger n | n < 0 = negate $ fromInteger $ negate n@@ -140,33 +140,37 @@ then let Signed x' = negate s in negate x' else x -instance NaturalT nT => Bits (Signed nT) where- (Signed a) .&. (Signed b) = Signed $ a .&. b- (Signed a) .|. (Signed b) = Signed $ a .|. b- (Signed a) `xor` Signed b = Signed $ a `xor` b- complement (Signed x) = Signed $ x `xor` mask (undefined :: nT)+instance NaturalT nT => B.Bits (Signed nT) where+ (Signed a) .&. (Signed b) = Signed $ a B..&. b+ (Signed a) .|. (Signed b) = Signed $ a B..|. b+ (Signed a) `xor` Signed b = Signed $ a `B.xor` b+ complement (Signed x) = Signed $ x `B.xor` mask (undefined :: nT) (Signed x) `shiftL` b | b < 0 = error $ "Bits.shiftL{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to shift by negative amount" | otherwise =- Signed $ mask (undefined :: nT) .&. (x `shiftL` b)+ Signed $ mask (undefined :: nT) B..&. (x `B.shiftL` b) s@(Signed x) `shiftR` b | b < 0 = error $ "Bits.shiftR{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to shift by negative amount" | isNegative s =- Signed $ mask (undefined :: nT) .&.- ((x `shiftR` b) .|. (mask (undefined :: nT) `shiftL` (fromIntegerT (undefined :: nT) - b)))+ Signed $ mask (undefined :: nT) B..&.+ ((x `B.shiftR` b) B..|. (mask (undefined :: nT) `B.shiftL` (fromIntegerT (undefined :: nT) - b))) | otherwise =- Signed $ (mask (undefined :: nT)) .&. (x `shiftR` b)+ Signed $ (mask (undefined :: nT)) B..&. (x `B.shiftR` b) (Signed a) `rotateL` b | b < 0 = error $ "Bits.rotateL{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to rotate by negative amount" | otherwise =- Signed $ mask (undefined :: nT) .&.- ((a `shiftL` b) .|. (a `shiftR` (fromIntegerT (undefined :: nT) - b)))+ Signed $ mask (undefined :: nT) B..&.+ ((a `B.shiftL` b) B..|. (a `B.shiftR` (fromIntegerT (undefined :: nT) - b))) (Signed a) `rotateR` b | b < 0 = error $ "Bits.rotateR{Signed " ++ show (fromIntegerT (undefined :: nT)) ++ "}: tried to rotate by negative amount" | otherwise =- Signed $ mask (undefined :: nT) .&.- ((a `shiftR` b) .|. (a `shiftL` (fromIntegerT (undefined :: nT) - b)))+ Signed $ mask (undefined :: nT) B..&.+ ((a `B.shiftR` b) B..|. (a `B.shiftL` (fromIntegerT (undefined :: nT) - b))) bitSize _ = fromIntegerT (undefined :: nT) isSigned _ = True++instance NaturalT nT => HWBits (Signed nT) where+ a `shiftL` b = a `B.shiftL` (fromInteger (toInteger b))+ a `shiftR` b = a `B.shiftR` (fromInteger (toInteger b))
Data/Param/Unsigned.hs view
@@ -1,13 +1,13 @@ {-# LANGUAGE TypeFamilies, TypeOperators, ScopedTypeVariables, FlexibleInstances, TemplateHaskell, Rank2Types, FlexibleContexts #-} module Data.Param.Unsigned ( Unsigned- , resize+ , resizeUnsigned , fromIndex ) where import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift(..))-import Data.Bits+import qualified Data.Bits as B import Types import Types.Data.Num.Decimal.Literals.TH @@ -27,8 +27,8 @@ ) => Index nT -> Unsigned nT' fromIndex index = Unsigned (toInteger index) -resize :: (NaturalT nT, NaturalT nT') => Unsigned nT -> Unsigned nT'-resize a = fromInteger (toInteger a)+resizeUnsigned :: (NaturalT nT, NaturalT nT') => Unsigned nT -> Unsigned nT'+resizeUnsigned a = fromInteger (toInteger a) sizeT :: Unsigned nT -> nT@@ -37,7 +37,7 @@ mask :: forall nT . NaturalT nT => nT -> Integer-mask _ = bit (fromIntegerT (undefined :: nT)) - 1+mask _ = B.bit (fromIntegerT (undefined :: nT)) - 1 instance NaturalT nT => Eq (Unsigned nT) where (Unsigned x) == (Unsigned y) = x == y@@ -57,7 +57,7 @@ instance NaturalT nT => Bounded (Unsigned nT) where minBound = 0- maxBound = Unsigned $ (1 `shiftL` (fromIntegerT (undefined :: nT))) - 1+ maxBound = Unsigned $ (1 `B.shiftL` (fromIntegerT (undefined :: nT))) - 1 instance NaturalT nT => Enum (Unsigned nT) where succ x@@ -88,13 +88,13 @@ (Unsigned a) * (Unsigned b) = fromInteger $ a * b negate s@(Unsigned n) =- fromInteger $ (n `xor` mask (sizeT s)) + 1+ fromInteger $ (n `B.xor` mask (sizeT s)) + 1 a - b = a + (negate b) fromInteger n | n > 0 =- Unsigned $ n .&. mask (undefined :: nT)+ Unsigned $ n B..&. mask (undefined :: nT) fromInteger n | n < 0 = negate $ fromInteger $ negate n@@ -128,30 +128,34 @@ in (fromInteger div, fromInteger mod) toInteger s@(Unsigned x) = x -instance NaturalT nT => Bits (Unsigned nT) where- (Unsigned a) .&. (Unsigned b) = Unsigned $ a .&. b- (Unsigned a) .|. (Unsigned b) = Unsigned $ a .|. b- (Unsigned a) `xor` Unsigned b = Unsigned $ a `xor` b- complement (Unsigned x) = Unsigned $ x `xor` mask (undefined :: nT)+instance NaturalT nT => B.Bits (Unsigned nT) where+ (Unsigned a) .&. (Unsigned b) = Unsigned $ a B..&. b+ (Unsigned a) .|. (Unsigned b) = Unsigned $ a B..|. b+ (Unsigned a) `xor` Unsigned b = Unsigned $ a `B.xor` b+ complement (Unsigned x) = Unsigned $ x `B.xor` mask (undefined :: nT) s@(Unsigned x) `shiftL` b- | b < 0 = error $ "Bits.shiftL{Unsigned " ++ show (bitSize s) ++ "}: tried to shift by negative amount"+ | b < 0 = error $ "Bits.shiftL{Unsigned " ++ show (B.bitSize s) ++ "}: tried to shift by negative amount" | otherwise =- Unsigned $ mask (undefined :: nT) .&. (x `shiftL` b)+ Unsigned $ mask (undefined :: nT) B..&. (x `B.shiftL` b) s@(Unsigned x) `shiftR` b- | b < 0 = error $ "Bits.shiftR{Unsigned " ++ show (bitSize s) ++ "}: tried to shift by negative amount"+ | b < 0 = error $ "Bits.shiftR{Unsigned " ++ show (B.bitSize s) ++ "}: tried to shift by negative amount" | otherwise =- Unsigned $ (x `shiftR` b)+ Unsigned $ (x `B.shiftR` b) s@(Unsigned x) `rotateL` b | b < 0 =- error $ "Bits.rotateL{Unsigned " ++ show (bitSize s) ++ "}: tried to rotate by negative amount"+ error $ "Bits.rotateL{Unsigned " ++ show (B.bitSize s) ++ "}: tried to rotate by negative amount" | otherwise =- Unsigned $ mask (undefined :: nT) .&.- ((x `shiftL` b) .|. (x `shiftR` (bitSize s - b)))+ Unsigned $ mask (undefined :: nT) B..&.+ ((x `B.shiftL` b) B..|. (x `B.shiftR` (B.bitSize s - b))) s@(Unsigned x) `rotateR` b | b < 0 =- error $ "Bits.rotateR{Unsigned " ++ show (bitSize s) ++ "}: tried to rotate by negative amount"+ error $ "Bits.rotateR{Unsigned " ++ show (B.bitSize s) ++ "}: tried to rotate by negative amount" | otherwise =- Unsigned $ mask (undefined :: nT) .&.- ((x `shiftR` b) .|. (x `shiftL` (bitSize s - b)))+ Unsigned $ mask (undefined :: nT) B..&.+ ((x `B.shiftR` b) B..|. (x `B.shiftL` (B.bitSize s - b))) bitSize _ = fromIntegerT (undefined :: nT) isSigned _ = False++instance NaturalT nT => HWBits (Unsigned nT) where+ a `shiftL` b = a `B.shiftL` (fromInteger (toInteger b))+ a `shiftR` b = a `B.shiftR` (fromInteger (toInteger b))
Data/Param/Vector.hs view
@@ -28,8 +28,8 @@ , foldr , zip , unzip- , shiftl- , shiftr+ , shiftIntoL+ , shiftIntoR , rotl , rotr , concat@@ -109,16 +109,14 @@ null :: Vector D0 a -> Bool null _ = True -(!) :: ( PositiveT s- , NaturalT u- , (s :>: u) ~ True) => Vector s a -> Index u -> a+(!) :: PositiveT s => Vector s a -> Index s -> a (Vector xs) ! i = xs !! (fromInteger (toInteger i)) -- ========================== -- = Transforming functions = -- ==========================-replace :: (PositiveT s, NaturalT u, (s :>: u) ~ True) =>- Vector s a -> Index u -> a -> Vector s a+replace :: PositiveT s =>+ Vector s a -> Index s -> a -> Vector s a replace (Vector xs) i y = Vector $ replace' xs (toInteger i) y where replace' [] _ _ = [] replace' (_:xs) 0 y = (y:xs)@@ -181,13 +179,13 @@ unzip :: Vector s (a, b) -> (Vector s a, Vector s b) unzip (Vector xs) = let (a,b) = P.unzip xs in (Vector a, Vector b) -shiftl :: (PositiveT s, NaturalT n, n ~ Pred s, s ~ Succ n) => - Vector s a -> a -> Vector s a-shiftl xs x = x +> init xs+shiftIntoL :: (PositiveT s, NaturalT n, n ~ Pred s, s ~ Succ n) => + Vector s a -> a -> Vector s a+shiftIntoL xs x = x +> init xs -shiftr :: (PositiveT s, NaturalT n, n ~ Pred s, s ~ Succ n) => - Vector s a -> a -> Vector s a-shiftr xs x = tail xs <+ x+shiftIntoR :: (PositiveT s, NaturalT n, n ~ Pred s, s ~ Succ n) => + Vector s a -> a -> Vector s a+shiftIntoR xs x = tail xs <+ x rotl :: forall s a . NaturalT s => Vector s a -> Vector s a rotl = liftV rotl'
clash.cabal view
@@ -1,5 +1,5 @@ name: clash-version: 0.1.0.2+version: 0.1.1.0 build-type: Simple synopsis: CAES Language for Synchronous Hardware (CLaSH) description: CLaSH is a tool-chain/language to translate subsets of@@ -19,7 +19,7 @@ Cabal-Version: >= 1.2 Library- build-depends: ghc >= 6.12 && < 6.13, pretty, vhdl > 0.1, haskell98, syb,+ build-depends: ghc >= 6.12 && < 6.13, pretty, vhdl > 0.1.1, haskell98, syb, data-accessor >= 0.2.1.3, containers, base >= 4 && < 5, transformers >= 0.2, filepath, template-haskell, data-accessor-template, data-accessor-transformers,