From: Christiaan Baaij Date: Fri, 19 Jun 2009 10:17:44 +0000 (+0200) Subject: Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project X-Git-Url: https://git.stderr.nl/gitweb?p=matthijs%2Fmaster-project%2Fc%CE%BBash.git;a=commitdiff_plain;h=e230d86ae7135a268a72cdffba947a9011001ec2 Merge branch 'cλash' of git.stderr.nl/matthijs/projects/master-project * 'cλash' of http://git.stderr.nl/matthijs/projects/master-project: Use highordtest in main, since that can now be normalized. Add a (fairly complete) set of transforms. Add is_lam and is_fun predicates. Add a inlinebind helper function. Add a substitute helper function. Print the type in the transform debug output. Add infrastructure for running core to core transformations. Add a higher order testcase. Add is_wild function to check for wild binders. Generate VHDL from Core instead of flat functions. Conflicts: Translator.hs VHDL.hs --- e230d86ae7135a268a72cdffba947a9011001ec2 diff --cc Main.hs index be0a0a0,0000000..be48aa3 mode 100644,000000..100644 --- a/Main.hs +++ b/Main.hs @@@ -1,6 -1,0 +1,6 @@@ +module Main where + +import Translator + +main = do - makeVHDL "Alu.hs" "exec" True ++ makeVHDL "Adders.hs" "highordtest" True diff --cc VHDL.hs index 846cd81,561c279..d177a10 --- a/VHDL.hs +++ b/VHDL.hs @@@ -34,22 -38,19 +38,22 @@@ import TranslatorType import HsValueMap import Pretty import CoreTools +import Constants +import Generate +import GlobalNameTable createDesignFiles :: - FlatFuncMap + [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -> [(AST.VHDLId, AST.DesignFile)] - createDesignFiles flatfuncmap = + createDesignFiles binds = (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) : map (Arrow.second $ AST.DesignFile full_context) units where - init_session = VHDLSession Map.empty builtin_funcs + init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable (units, final_session) = - State.runState (createLibraryUnits flatfuncmap) init_session + State.runState (createLibraryUnits binds) init_session ty_decls = Map.elems (final_session ^. vsTypes) ieee_context = [ AST.Library $ mkVHDLBasicId "IEEE", @@@ -106,24 -105,23 +108,23 @@@ createEntity (fname, expr) = d return ent_decl' where mkMap :: - [(SignalId, SignalInfo)] - -> SignalId + --[(SignalId, SignalInfo)] + CoreSyn.CoreBndr -> VHDLState VHDLSignalMapElement -- We only need the vsTypes element from the state - mkMap sigmap = (\id -> - mkMap = MonadState.lift vsTypes . (\bndr -> ++ mkMap = (\bndr -> let - info = Maybe.fromMaybe - (error $ "Signal not found in the name map? This should not happen!") - (lookup id sigmap) - nm = Maybe.fromMaybe - (error $ "Signal not named? This should not happen!") - (sigName info) - ty = sigTy info + --info = Maybe.fromMaybe + -- (error $ "Signal not found in the name map? This should not happen!") + -- (lookup id sigmap) + -- Assume the bndr has a valid VHDL id already + id = bndrToVHDLId bndr + ty = Var.varType bndr in - if isPortSigUse $ sigUse info + if True -- isPortSigUse $ sigUse info then do type_mark <- vhdl_ty ty - return $ Just (mkVHDLExtId nm, type_mark) + return $ Just (id, type_mark) else return $ Nothing ) @@@ -170,31 -167,31 +170,31 @@@ mkEntityId hsfunc -- | Create an architecture for a given function createArchitecture :: - HsFunction -- ^ The function signature - -> FlatFunction -- ^ The FlatFunction + (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function -> VHDLState AST.ArchBody -- ^ The architecture for this function - createArchitecture hsfunc flatfunc = do - signaturemap <- getA vsSignatures - let signature = Maybe.fromMaybe - (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!") - (Map.lookup hsfunc signaturemap) - let entity_id = ent_id signature + createArchitecture (fname, expr) = do + --signaturemap <- getA vsSignatures + --let signature = Maybe.fromMaybe + -- (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!") + -- (Map.lookup hsfunc signaturemap) + let entity_id = mkVHDLBasicId $ bndrToString fname + -- Strip off lambda's, these will be arguments + let (args, letexpr) = CoreSyn.collectBinders expr + -- There must be a let at top level + let (CoreSyn.Let (CoreSyn.Rec binds) res) = letexpr + -- Create signal declarations for all internal and state signals - sig_dec_maybes <- mapM (mkSigDec' . snd) sigs + sig_dec_maybes <- mapM (mkSigDec' . fst) binds let sig_decs = Maybe.catMaybes $ sig_dec_maybes - -- Create concurrent statements for all signal definitions - statements <- Monad.zipWithM (mkConcSm sigs) defs [0..] + + statements <- Monad.mapM mkConcSm binds return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs') where - sigs = flat_sigs flatfunc - args = flat_args flatfunc - res = flat_res flatfunc - defs = flat_defs flatfunc - procs = map mkStateProcSm (makeStatePairs flatfunc) + procs = map mkStateProcSm [] -- (makeStatePairs flatfunc) procs' = map AST.CSPSm procs -- mkSigDec only uses vsTypes from the state - mkSigDec' = MonadState.lift vsTypes . mkSigDec + mkSigDec' = mkSigDec -- | Looks up all pairs of old state, new state signals, together with -- the state id they represent. @@@ -223,16 -220,13 +223,13 @@@ mkStateProcSm (num, old, new) rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)] statement = AST.IfSm rising_edge_clk [assign] [] Nothing - mkSigDec :: SignalInfo -> VHDLState (Maybe AST.SigDec) - mkSigDec info = - let use = sigUse info in - if isInternalSigUse use || isStateSigUse use then do - type_mark <- vhdl_ty ty - return $ Just (AST.SigDec (getSignalId info) type_mark Nothing) -mkSigDec :: CoreSyn.CoreBndr -> TypeState (Maybe AST.SigDec) ++mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec) + mkSigDec bndr = + if True then do --isInternalSigUse use || isStateSigUse use then do + type_mark <- vhdl_ty $ Var.varType bndr + return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing) else return Nothing - where - ty = sigTy info -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo -- is not named. diff --cc VHDLTypes.hs index f317167,784b097..e517a8b --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@@ -44,25 -45,15 +45,25 @@@ instance Ord OrdType wher -- A map of a Core type to the corresponding type name type TypeMap = Map.Map OrdType (AST.VHDLId, AST.TypeDec) +-- A map of a vector Core type to the coressponding VHDL functions +type TypeFunMap = Map.Map OrdType [AST.SubProgBody] + -- A map of a Haskell function to a hardware signature - type SignatureMap = Map.Map HsFunction Entity + type SignatureMap = Map.Map String Entity +-- A map of a builtin function to VHDL function builder +type NameTable = Map.Map String (Int, [AST.Expr] -> AST.Expr ) + data VHDLSession = VHDLSession { -- | A map of Core type -> VHDL Type - vsTypes_ :: TypeMap, + vsTypes_ :: TypeMap, + -- | A map of vector Core type -> VHDL type function + vsTypeFuns_ :: TypeFunMap, -- | A map of HsFunction -> hardware signature (entity name, port names, -- etc.) - vsSignatures_ :: SignatureMap + vsSignatures_ :: SignatureMap, + -- | A map of Vector HsFunctions -> VHDL function call + vsNameTable_ :: NameTable } -- Derive accessors