diff --git a/CLasH/Normalize.hs b/CLasH/Normalize.hs --- a/CLasH/Normalize.hs +++ b/CLasH/Normalize.hs @@ -164,10 +164,29 @@ 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) + -- If we inline a top-level function which has an associated + -- initial state, and if the body of of the function is an + -- Application. Then we need to clone the function indicated + -- by the first argument of the application, and associate the + -- initial state with this clone. We also need to replace the + -- original reference with a reference to this clone + initSmap <- Trans.lift $ MonadState.get tsInitStates + case (CoreSyn.collectArgs body, Map.lookup f initSmap) of + ((Var inlineF, inlineFargs), Just initState) -> do + -- Get the body belong to the applied function and clone it + inlineFbody <- Trans.lift $ getGlobalBind inlineF + newInlineF <- Trans.lift $ mkFunction inlineF (Maybe.fromJust inlineFbody) + -- Associate the initial state with the cloned function + Trans.lift $ MonadState.modify tsInitStates (\ismap -> Map.insert (newInlineF) initState ismap) + -- Replace original reference with a reference to the cloned function + let newBody = mkApps (Var newInlineF) inlineFargs + newBodyUniqued <- Trans.lift $ genUniques newBody + change (mkApps newBodyUniqued args) + _ -> 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. @@ -675,12 +694,13 @@ let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs) -- Create a new function with the same name but a new body newf <- Trans.lift $ mkFunction f newbody - Trans.lift $ MonadState.modify tsInitStates (\ismap -> - let init_state_maybe = Map.lookup f ismap in - case init_state_maybe of - Nothing -> ismap - Just init_state -> Map.insert newf init_state ismap) + let + init_state_maybe = Map.lookup f ismap + in + case init_state_maybe of + Nothing -> ismap + Just init_state -> Map.insert (newf) init_state ismap) -- Replace the original application with one of the new function to the -- new arguments. change $ MkCore.mkCoreApps (Var newf) newargs @@ -1050,15 +1070,7 @@ otherwise -> do initId <- Trans.lift $ mkBinderFor initvalue ("init" ++ Name.getOccString realfunBndr) Trans.lift $ addGlobalBind initId initvalue - return initId - -- 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 + 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)))) @@ -1473,23 +1485,9 @@ getNormalized_maybe result_nonrep bndr = do 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) - MonadState.modify tsInitStates (Map.insert bndr 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 + case (isArrowB bndr, expr_maybe) of + -- The bndr is an Arrow + (True, Just arrowf) -> do normalizedA <- Utils.makeCached bndr tsNormalized $ do { -- First apply the transformations that remove the arrows ; arrowLessExpr <- normalizeExpr (show bndr) aTransforms arrowf @@ -1505,7 +1503,7 @@ MonadState.modify tsArrows (Map.insert bndr realfun) return (Just normalizedA) -- The expression is not an Arrow - (False, Just expr, False) -> do + (False, Just expr) -> do normalizeable <- isNormalizeable result_nonrep bndr if not normalizeable then diff --git a/CLasH/Translator.hs b/CLasH/Translator.hs --- a/CLasH/Translator.hs +++ b/CLasH/Translator.hs @@ -81,8 +81,8 @@ let all_bindings = concatMap (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores -- Store the bindings we loaded tsBindings %= Map.fromList all_bindings - let all_initstates = concatMap (\x -> case x of (_, Nothing, _) -> []; (_, Just inits, _) -> inits) specs - tsInitStates %= Map.fromList all_initstates + -- let all_initstates = concatMap (\x -> case x of (_, Nothing, _) -> []; (_, Just inits, _) -> inits) specs + tsInitStates %= Map.empty test_binds <- catMaybesM $ Monad.mapM mkTest specs let topbinds = Maybe.catMaybes $ map (\(top, _, _) -> top) specs vhdl <- case topbinds of diff --git a/CLasH/VHDL/Generate.hs b/CLasH/VHDL/Generate.hs --- a/CLasH/VHDL/Generate.hs +++ b/CLasH/VHDL/Generate.hs @@ -130,13 +130,13 @@ let (statementss, used_entitiess) = unzip sms -- Get initial state, if it's there initSmap <- MonadState.get tsInitStates - let init_state = Map.lookup fname initSmap + let init_state = Map.lookup (fname) initSmap -- 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 "\n Generate.getArchitecture (in_state)" in_state if nonEmpty - then error ("No initial state defined for: " ++ show fname) + then error ("Generate.getArchitecture: No initial state defined for: " ++ show fname) else return ([],[]) ([in_state], [out_state], Just resetval) -> do nonEmpty <- hasNonEmptyType "" in_state @@ -1079,7 +1079,7 @@ 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)) + ; return $ (genExprFCall2 (mkVHDLBasicId "shift_right") (arg1, (genExprFCall (mkVHDLBasicId toIntegerId) arg2))) } ----------------------------------------------------------------------------- diff --git a/clash.cabal b/clash.cabal --- a/clash.cabal +++ b/clash.cabal @@ -1,5 +1,5 @@ name: clash -version: 0.1.2.2 +version: 0.1.2.3 build-type: Simple synopsis: CAES Language for Synchronous Hardware (CLaSH) description: CLaSH is a tool-chain/language to translate subsets of