diff --git a/CLasH/HardwareTypes.hs b/CLasH/HardwareTypes.hs --- a/CLasH/HardwareTypes.hs +++ b/CLasH/HardwareTypes.hs @@ -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 diff --git a/CLasH/Normalize.hs b/CLasH/Normalize.hs --- a/CLasH/Normalize.hs +++ b/CLasH/Normalize.hs @@ -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) $ diff --git a/CLasH/Normalize/NormalizeTools.hs b/CLasH/Normalize/NormalizeTools.hs --- a/CLasH/Normalize/NormalizeTools.hs +++ b/CLasH/Normalize/NormalizeTools.hs @@ -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 diff --git a/CLasH/Normalize/NormalizeTypes.hs b/CLasH/Normalize/NormalizeTypes.hs --- a/CLasH/Normalize/NormalizeTypes.hs +++ b/CLasH/Normalize/NormalizeTypes.hs @@ -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 diff --git a/CLasH/Translator.hs b/CLasH/Translator.hs --- a/CLasH/Translator.hs +++ b/CLasH/Translator.hs @@ -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 diff --git a/CLasH/Translator/TranslatorTypes.hs b/CLasH/Translator/TranslatorTypes.hs --- a/CLasH/Translator/TranslatorTypes.hs +++ b/CLasH/Translator/TranslatorTypes.hs @@ -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 diff --git a/CLasH/Utils/Core/CoreTools.hs b/CLasH/Utils/Core/CoreTools.hs --- a/CLasH/Utils/Core/CoreTools.hs +++ b/CLasH/Utils/Core/CoreTools.hs @@ -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) diff --git a/CLasH/Utils/Pretty.hs b/CLasH/Utils/Pretty.hs --- a/CLasH/Utils/Pretty.hs +++ b/CLasH/Utils/Pretty.hs @@ -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 == '_' diff --git a/CLasH/VHDL/Constants.hs b/CLasH/VHDL/Constants.hs --- a/CLasH/VHDL/Constants.hs +++ b/CLasH/VHDL/Constants.hs @@ -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 diff --git a/CLasH/VHDL/Generate.hs b/CLasH/VHDL/Generate.hs --- a/CLasH/VHDL/Generate.hs +++ b/CLasH/VHDL/Generate.hs @@ -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")) ] diff --git a/CLasH/VHDL/Testbench.hs b/CLasH/VHDL/Testbench.hs --- a/CLasH/VHDL/Testbench.hs +++ b/CLasH/VHDL/Testbench.hs @@ -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) diff --git a/CLasH/VHDL/VHDLTools.hs b/CLasH/VHDL/VHDLTools.hs --- a/CLasH/VHDL/VHDLTools.hs +++ b/CLasH/VHDL/VHDLTools.hs @@ -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) diff --git a/Data/Param/Index.hs b/Data/Param/Index.hs --- a/Data/Param/Index.hs +++ b/Data/Param/Index.hs @@ -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) diff --git a/Data/Param/Integer.hs b/Data/Param/Integer.hs --- a/Data/Param/Integer.hs +++ b/Data/Param/Integer.hs @@ -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 diff --git a/Data/Param/Signed.hs b/Data/Param/Signed.hs --- a/Data/Param/Signed.hs +++ b/Data/Param/Signed.hs @@ -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)) diff --git a/Data/Param/Unsigned.hs b/Data/Param/Unsigned.hs --- a/Data/Param/Unsigned.hs +++ b/Data/Param/Unsigned.hs @@ -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)) diff --git a/Data/Param/Vector.hs b/Data/Param/Vector.hs --- a/Data/Param/Vector.hs +++ b/Data/Param/Vector.hs @@ -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' diff --git a/clash.cabal b/clash.cabal --- a/clash.cabal +++ b/clash.cabal @@ -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,