From: Christiaan Baaij Date: Mon, 13 Jul 2009 10:01:00 +0000 (+0200) Subject: Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=83a9910bd8031fbce225992e432e7dfba73b5c0f;hp=aa23b0116eaf65b01499cd1eba93a92f7c8c36e8;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Merge branch 'cλash' of git.stderr.nl/matthijs/projects/master-project * 'cλash' of http://git.stderr.nl/matthijs/projects/master-project: Generate proper VHDL for top level bindings with no arguments. Use is_local_var for limiting appsimpl and letsimpl. Add newline at the end of file. Add is_local_var predicate. Santize comment dashes position. Normalize all used global binders. --- diff --git a/Adders.hs b/Adders.hs index f0987fd..a281ea6 100644 --- a/Adders.hs +++ b/Adders.hs @@ -181,6 +181,9 @@ xand a b = hwand a b functiontest :: TFVec D3 (TFVec D4 Bit) -> TFVec D12 Bit functiontest = \v -> let r = concat v in r +functiontest2 :: SizedInt D8 -> SizedInt D8 +functiontest2 = \a -> let r = a + 1 in r + xhwnot x = hwnot x maptest :: TFVec D4 Bit -> TFVec D4 Bit diff --git a/CoreTools.hs b/CoreTools.hs index 9888255..3bfe1a1 100644 --- a/CoreTools.hs +++ b/CoreTools.hs @@ -223,4 +223,4 @@ getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr] getLiterals app@(CoreSyn.App _ _) = literals where (CoreSyn.Var f, args) = CoreSyn.collectArgs app - literals = filter (is_lit) args \ No newline at end of file + literals = filter (is_lit) args diff --git a/Generate.hs b/Generate.hs index e7a5198..4f0acf3 100644 --- a/Generate.hs +++ b/Generate.hs @@ -44,7 +44,7 @@ genExprArgs :: -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res) genExprArgs ty_state wrap dst func args = wrap dst func args' where args' = map (either ((varToVHDLExpr ty_state).exprToVar) id) args - + -- | A function to wrap a builder-like function that expects its arguments to -- be variables. genVarArgs :: @@ -514,17 +514,25 @@ genApplication dst f args = do signatures <- getA vsSignatures -- This is a local id, so it should be a function whose definition we -- have and which can be turned into a component instantiation. - let - signature = Maybe.fromMaybe - (error $ "\nGenerate.genApplication: Using function '" ++ (varToString f) ++ "' without signature? This should not happen!") - (Map.lookup f signatures) - entity_id = ent_id signature - -- TODO: Using show here isn't really pretty, but we'll need some - -- unique-ish value... - label = "comp_ins_" ++ (either show prettyShow) dst - portmaps = mkAssocElems (map (either (exprToVHDLExpr ty_state) id) args) ((either varToVHDLName id) dst) signature - in - return [mkComponentInst label entity_id portmaps] + case (Map.lookup f signatures) of + Just signature -> let + -- We have a signature, this is a top level binding. Generate a + -- component instantiation. + entity_id = ent_id signature + -- TODO: Using show here isn't really pretty, but we'll need some + -- unique-ish value... + label = "comp_ins_" ++ (either show prettyShow) dst + portmaps = mkAssocElems (map (either (exprToVHDLExpr ty_state) id) args) ((either varToVHDLName id) dst) signature + in + return [mkComponentInst label entity_id portmaps] + Nothing -> do + -- No signature, so this must be a local variable reference. It + -- should have a representable type (and thus, no arguments) and a + -- signal should be generated for it. Just generate an + -- unconditional assignment here. + ty_state <- getA vsType + return $ [mkUncondAssign dst ((varToVHDLExpr ty_state) f)] + IdInfo.ClassOpId cls -> do -- FIXME: Not looking for what instance this class op is called for -- Is quite stupid of course. diff --git a/Normalize.hs b/Normalize.hs index fe544ed..16d7969 100644 --- a/Normalize.hs +++ b/Normalize.hs @@ -101,14 +101,21 @@ letrectop = everywhere ("letrec", letrec) -- let simplification -------------------------------- letsimpl, letsimpltop :: Transform --- Don't simplifiy lets that are already simple -letsimpl expr@(Let _ (Var _)) = return expr -- Put the "in ..." value of a let in its own binding, but not when the -- expression is applicable (to prevent loops with inlinefun). -letsimpl (Let (Rec binds) expr) | not $ is_applicable expr = do - id <- mkInternalVar "foo" (CoreUtils.exprType expr) - let bind = (id, expr) - change $ Let (Rec (bind:binds)) (Var id) +letsimpl expr@(Let (Rec binds) res) | not $ is_applicable expr = do + local_var <- Trans.lift $ is_local_var res + if not local_var + then do + -- If the result is not a local var already (to prevent loops with + -- ourselves), extract it. + id <- mkInternalVar "foo" (CoreUtils.exprType res) + let bind = (id, res) + change $ Let (Rec (bind:binds)) (Var id) + else + -- If the result is already a local var, don't extract it. + return expr + -- Leave all other expressions unchanged letsimpl expr = return expr -- Perform this transform everywhere @@ -144,7 +151,7 @@ letflattop = everywhere ("letflat", letflat) -------------------------------- -- Remove a = b bindings from let expressions everywhere letremovetop :: Transform -letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) | not $ Id.isDataConWorkId v -> return True; otherwise -> return False)) +letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> Trans.lift $ is_local_var e)) -------------------------------- -- Function inlining @@ -293,14 +300,13 @@ caseremovetop = everywhere ("caseremove", caseremove) -------------------------------- -- Make sure that all arguments of a representable type are simple variables. appsimpl, appsimpltop :: Transform --- Don't simplify arguments that are already simple. -appsimpl expr@(App f (Var v)) = return expr -- Simplify all representable arguments. Do this by introducing a new Let -- that binds the argument and passing the new binder in the application. appsimpl expr@(App f arg) = do -- Check runtime representability repr <- isRepr arg - if repr + local_var <- Trans.lift $ is_local_var arg + if repr && not local_var then do -- Extract representable arguments id <- mkInternalVar "arg" (CoreUtils.exprType arg) change $ Let (Rec [(id, arg)]) (App f (Var id)) @@ -514,29 +520,11 @@ normalizeBind bndr = -- Find all vars used with a function type. All of these should be global -- binders (i.e., functions used), since any local binders with a function -- type should have been inlined already. - let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> (Type.isFunTy . snd . Type.splitForAllTys . Id.idType) v) expr' + bndrs <- getGlobalBinders + let used_funcs_set = CoreFVs.exprSomeFreeVars (\v -> not (Id.isDictId v) && v `elem` bndrs) expr' let used_funcs = VarSet.varSetElems used_funcs_set -- Process each of the used functions recursively mapM normalizeBind used_funcs - -- FIXME: Can't we inline these 'implicit' function calls or something? - -- TODO: Add an extra let expression to the current finding, so the VHDL - -- Will make a signa assignment for this 'implicit' function call - -- - -- Find all the other free variables used that are used. This applies to - -- variables that are actually a reference to a Class function. Example: - -- - -- functiontest :: SizedInt D8 -> SizedInt D8 - -- functiontest = \a -> let r = a + 1 in r - -- - -- The literal(Lit) '1' will be turned into a variable (Var) - -- As it will call the 'fromInteger' class function that belongs - -- to the Num class. So we need to translate the refenced function - -- let used_vars_set = CoreFVs.exprSomeFreeVars (\v -> (Type.isAlgType . snd . Type.splitForAllTys . Id.idType) v) expr' - -- let used_vars = VarSet.varSetElems used_vars_set - -- -- Filter for dictionary args, they should not be translated - -- -- FIXME: check for other non-translatable stuff as well - -- let trans_vars = filter (\v -> (not . TcType.isDictTy . Id.idType) v) used_vars - -- mapM normalizeBind trans_vars return () -- We don't have a value for this binder. This really shouldn't -- happen for local id's... diff --git a/NormalizeTools.hs b/NormalizeTools.hs index 0508b38..1290fd8 100644 --- a/NormalizeTools.hs +++ b/NormalizeTools.hs @@ -106,15 +106,15 @@ applyboth first (name, second) expr = do -- Apply the second (expr'', changed) <- Writer.listen $ second expr' if Monoid.getAny $ - -- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $ +-- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $ changed then -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $ - -- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $ +-- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $ applyboth first (name, second) $ expr'' else - -- trace ("No changes") $ +-- trace ("No changes") $ return expr'' -- Apply the given transformation to all direct subexpressions (only), not the @@ -258,3 +258,9 @@ runTransformSession env uniqSupply session = State.evalState session emptyTransf isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool isRepr (Type ty) = return False isRepr expr = Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType (CoreUtils.exprType expr) + +is_local_var :: CoreSyn.CoreExpr -> TransformSession Bool +is_local_var (CoreSyn.Var v) = do + bndrs <- getGlobalBinders + return $ not $ v `elem` bndrs +is_local_var _ = return False diff --git a/VHDL.hs b/VHDL.hs index 6039447..2ac2a12 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -254,13 +254,11 @@ mkConcSm :: -- the type works out. mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr) --- For simple a = b assignments, just generate an unconditional signal --- assignment. This should only happen for dataconstructors without arguments. --- TODO: Integrate this with the below code for application (essentially this --- is an application without arguments) +-- 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, Var v) = do - ty_state <- getA vsType - return $ [mkUncondAssign (Left bndr) ((varToVHDLExpr ty_state) v)] + genApplication (Left bndr) v [] mkConcSm (bndr, app@(CoreSyn.App _ _))= do let (CoreSyn.Var f, args) = CoreSyn.collectArgs app