-- UUAGC 0.9.52.1 (build/103/lib-ehc/UHC/Light/Compiler/Core.ag) module UHC.Light.Compiler.Core(module UHC.Light.Compiler.AbstractCore , module UHC.Light.Compiler.Base.Target , CodeAGItf (..), CModule (..), CExpr (..), CBind (..), CBound (..), CBindL, CBoundL, CPatRest (..), CAlt (..), CAltL, CPat (..), CPatFld (..), CPatFldL , CBindAnn (..), CBindAnnL, CExprAnn (..) , CExport (..), CExportL, CImport (..), CImportL , CDeclMeta (..), CDeclMetaL, CDataCon (..), CDataConL , RAlt, RPat, RPatConBind, RPatFld , CBindCateg (..) , EvalCtx (..), evalCtxIsStrict , cexprIsLam , cbindNm , mkCMod, emptyCModule , cexprMbVar, cexprVar , cexprTupFld , cexprIsEvaluated , CVarIntro (..), emptyCVarIntro , CVarIntroMp, CVarIntroL, cviLookup , cLevModule, cLevExtern , CVarRepl (..) , CVarReplMp , CVarReplNm, emptyCVarReplNm , CVarReplNmMp, CVarReplNmL , cvrFromCvi , fvLev, fvsLev , SysfTy, SysfTyBind, SysfTyBound, SysfTySeq, SysfTySeq1 , CTy, mkCTy, mkSTy, cty , cbindLNub , cTupLbl , cTupTag , cTupOff , cmodSetImports , cbindAspectMbExpr, cbindExprs , cLevIntern , cModMergeByConcat , CDbBindLetInfo , CDbBindRef, CDbModuleBindMp , CModuleDatabase (..), emptyCModuleDatabase , cmoddbLookup , module UHC.Light.Compiler.Foreign) where import UHC.Light.Compiler.Base.HsName.Builtin import UHC.Light.Compiler.Base.Common import UHC.Light.Compiler.Base.TermLike import UHC.Light.Compiler.Opts.Base import UHC.Light.Compiler.AbstractCore import UHC.Light.Compiler.Base.Target (FFIWay (..),TargetFlavor (..)) import Data.Maybe import Data.Char import Data.List import UHC.Util.Utils import UHC.Util.Pretty import Control.Applicative ((<|>)) import qualified Data.Map as Map import qualified Data.Set as Set import UHC.Light.Compiler.Ty import UHC.Light.Compiler.Module.Merge import Data.Array import Control.Monad import UHC.Util.Binary import UHC.Util.Serialize import UHC.Light.Compiler.Foreign -- | Explicit dummy instances instead of derived ones which not really are used except as context for PP instance Show CExpr where show _ = "CExpr" instance Show CBound where show _ = "CBound" type RAlt = RAlt' CExpr CTy CBind CPatRest type RPat = RPat' CExpr CTy CBind CPatRest type RPatConBind = RPatConBind' CExpr CTy CBind CPatRest type RPatFld = RPatFld' CExpr CTy CBind CPatRest -- | Set imports cmodSetImports :: [HsName] -> CModule -> CModule cmodSetImports imp m = m {imports_CModule_Mod = map CImport_Import imp} cTupLbl :: CExpr -> HsName cTupLbl e = case e of CExpr_TupIns _ _ l _ _ -> l CExpr_TupUpd _ _ l _ _ -> l CExpr_TupDel _ _ l _ -> l cTupTag :: CExpr -> CTag cTupTag e = case e of CExpr_TupIns _ t _ _ _ -> t CExpr_TupUpd _ t _ _ _ -> t CExpr_TupDel _ t _ _ -> t cTupOff :: CExpr -> CExpr cTupOff e = case e of CExpr_TupIns _ _ _ o _ -> o CExpr_TupUpd _ _ _ o _ -> o CExpr_TupDel _ _ _ o -> o data CBindCateg = CBindCateg_Rec -- mutually recursive | CBindCateg_Strict -- strictly evaluated | CBindCateg_Plain -- plain | CBindCateg_FFI -- imported function | CBindCateg_FFE -- exported function (not implemented yet) deriving (Show,Eq,Enum) instance PP CBindCateg where pp = pp . show deriving instance Typeable CBindCateg data EvalCtx = EvalCtx_None -- nothing known, no strictness required, no thunking | EvalCtx_Thunk -- lazy/thunked representation required | EvalCtx_PApp0 -- partial app of lam with 0 params | EvalCtx_Eval -- strictness (thus eval) required | EvalCtx_EvalUnbox -- strictness (thus eval) + unboxing required deriving Eq evalCtxIsStrict:: EvalCtx -> Bool evalCtxIsStrict EvalCtx_Eval = True evalCtxIsStrict EvalCtx_EvalUnbox = True evalCtxIsStrict _ = False cexprIsLam :: CExpr -> Bool cexprIsLam (CExpr_Lam _ _) = True cexprIsLam _ = False cbindNm :: CBind -> HsName cbindNm (CBind_Bind n _) = n -- cbindNm (CBind_FFI _ _ _ n _ ) = n -- | extract expr for aspect, relevant for later use/analysis/... cbindAspectMbExpr :: CBound -> Maybe CExpr cbindAspectMbExpr (CBound_Bind e) = Just e cbindAspectMbExpr (CBound_Val _ _ _ e) = Just e cbindAspectMbExpr _ = Nothing -- | extract exprs of a binding which are relevant for use/analysis/... cbindExprs :: CBind -> [CExpr] cbindExprs (CBind_Bind _ a) = catMaybes $ map cbindAspectMbExpr a cbindLNub :: CBindL -> CBindL cbindLNub = nubBy (\b1 b2 -> cbindNm b1 == cbindNm b2) mkCMod :: CExpr -> CModule mkCMod e = CModule_Mod (hsnFromString "") [] [] [] e -- [] emptyCModule :: CModule emptyCModule = mkCMod (CExpr_Int 0) cexprMbVar :: CExpr -> Maybe HsName cexprMbVar (CExpr_Var r) = Just (acbrefNm r) cexprMbVar _ = Nothing cexprVar :: CExpr -> HsName cexprVar = maybe hsnUnknown id . cexprMbVar cexprTupFld :: CExpr -> CExpr cexprTupFld (CExpr_TupIns _ _ _ _ e) = e cexprTupFld _ = panic "Core.cexprTupFld" -- acoreVar hsnUnknown cexprIsEvaluated :: CExpr -> Bool cexprIsEvaluated (CExpr_Int _) = True cexprIsEvaluated (CExpr_Char _) = True cexprIsEvaluated _ = False data CVarIntro = CVarIntro { cviLev :: Int -- lexical level } emptyCVarIntro :: CVarIntro emptyCVarIntro = CVarIntro cLevExtern type CVarIntroMp = Map.Map HsName CVarIntro type CVarIntroL = AssocL HsName CVarIntro cviLookup :: HsName -> CVarIntroMp -> CVarIntro cviLookup n m = Map.findWithDefault emptyCVarIntro n m cLevModule, cLevExtern :: Int cLevModule = 0 cLevExtern = 0 cLevIntern :: Int cLevIntern = 1 data CVarRepl r = CVarRepl { cvrRepl :: r -- replacement } type CVarReplMp r = Map.Map HsName (CVarRepl r) type CVarReplAsc r = AssocL HsName (CVarRepl r) type CVarReplNm = CVarRepl HsName emptyCVarReplNm :: CVarReplNm emptyCVarReplNm = CVarRepl hsnUnknown type CVarReplNmMp = CVarReplMp HsName type CVarReplNmL = CVarReplAsc HsName cvrFromCvi :: CVarIntro -> CVarReplNm cvrFromCvi i = emptyCVarReplNm fvLev :: HsName -> CVarIntroMp -> Int fvLev n m = cviLev $ cviLookup n m fvsLev :: CVarIntroMp -> Int -> FvS -> Int fvsLev lm lDflt fvs = foldr (\n l -> fvLev n lm `max` l) lDflt $ Set.toList $ fvs -- | merge by concatenation cModMergeByConcat :: [CModule] -> CModule cModMergeByConcat mL = foldr1 cmb mL where get (CExpr_Let c b e) = CExpr_Let c b . get e get _ = id cmb (CModule_Mod m1 ex1 im1 mt1 e1) (CModule_Mod m2 ex2 im2 mt2 e2) = CModule_Mod m2 (ex1++ex2) (im1++im2) (mt1++mt2) (get e1 e2) -- | the binding info required for let bind type CDbBindLetInfo' f = ModDbBindLetInfo'' f CBindCateg CBind type CDbBindLetInfo = CDbBindLetInfo' [] -- | actual bindings stored in separate array to allow for sharing type CDbBindArray = ModDbBindArray' CBindCateg CBind -- | reference into database of bindings, agnostic of name given to it type CDbBindRef = (Int,Int) -- | binding map of global names to individual bindings type CDbModuleBindMp = Map.Map HsName CDbBindRef -- | the full module represented in a map/database like format (20101004 AD: to be made into persistent db soon) data CModuleDatabase = CModuleDatabase { cmoddbModNm :: !HsName -- module name , cmoddbBindArr :: !CDbBindArray -- bindings , cmoddbBindMp :: !CDbModuleBindMp -- map of name to bindings , cmoddbMainExpr :: !CExpr -- the final expr of the module's let expr , cmoddbExports :: !CExportL -- exports , cmoddbImports :: !CImportL -- imports , cmoddbMeta :: !CDeclMetaL -- meta info/decl } emptyCModuleDatabase :: CModuleDatabase emptyCModuleDatabase = CModuleDatabase hsnUnknown (array (1,0) []) Map.empty (CExpr_Int 0) [] [] [] cmoddbLookup :: HsName -> CModuleDatabase -> Maybe CDbBindRef cmoddbLookup n db = Map.lookup n $ cmoddbBindMp db -- | If there is no SysF used, just the plain type (used during type check/infer) type SysfTy = Ty -- base ty type SysfTyBind = Ty -- binder type SysfTyBound = Ty -- to be bound by binder type SysfTySeq = SysfTy -- sequence type SysfTySeq1 = SysfTy -- singleton -- | In case of SysF isomorphic to Either 'old ty' 'sysf ty', to be chosen at a higher level type CTy = Ty -- | Make CTy, ignoring the second Ty arg, which is a dummy anyway mkCTy :: EHCOpts -> Ty -> SysfTy -> CTy mkCTy _ t _ = t -- | Make CTy from sysf ty mkSTy :: SysfTy -> CTy mkSTy = id {-# INLINE mkSTy #-} -- | CTy fold, using the first 'f' cty :: (Ty -> x) -> (SysfTy -> x) -> CTy -> x cty f _ t = f t instance AbstractCore CExpr CBind CBound ACoreAppLikeMetaBound CBindCateg CTy CPat CPatRest CPatFld CAlt where -- expr acore1AppBound f a = CExpr_App f a -- acoreLam1Ty a _ e = CExpr_Lam (acoreBind1 a) e acoreLam1Bind b e = CExpr_Lam b e acoreTagTyTupBound tg _ es = acoreAppBound (CExpr_Tup tg) es acoreBoundVal1CatLevTy _ _ m _ e = CBound_Bind e acoreBoundmeta a m l = (a,m,l) acoreBound1Boundmeta (a,m,l) e = CBound_Val a m l e acoreBoundValTy1CatLev _ _ _ t = CBound_Ty acbaspkeyDefaultTy t acoreBind1Asp n as = CBind_Bind n as acoreBind1CatLevTy bcat n mlev t e = acoreBind1Asp n [acoreBoundValTy1CatLev bcat n (mlev+1) t, acoreBoundVal1CatLevTy bcat n mlev t e] acoreLetBase = CExpr_Let acoreCaseDflt e as d = CExpr_Case e as (maybe (acoreVar hsnUnknown) id d) acoreVar n = CExpr_Var (acoreMkRef n) acoreStringTy _ i = CExpr_String i acoreCharTy _ i = CExpr_Char i acoreIntTy _ i = CExpr_Int i acoreIntTy2 _ i = CExpr_Int (fromInteger i) acoreUidHole = CExpr_Hole acoreHoleLet = CExpr_HoleLet -- acoreDflt = acoreExprErr = CExpr_Dbg -- ty constants acoreTyBool o = acoreTy2ty o $ appCon (ehcOptBuiltin o ehbnDataBool) -- ty -- acoreTyInt2 = tyInt acoreTy2ty _ = id -- pat acorePatVarTy n _ = CPat_Var n acorePatCon = CPat_Con acorePatIntTy _ i = CPat_Int i acorePatIntTy2 _ i = CPat_Int (fromInteger i) acorePatCharTy _ i = CPat_Char i acorePatBoolExpr = CPat_BoolExpr -- patfld acorePatFldBind (lbl,off) b = CPatFld_Fld lbl off b [] -- acorePatFldTy _ (lbl,off) n = CPatFld_Fld lbl off n [] -- patrest acorePatRestEmpty = CPatRest_Empty acorePatRestVar = CPatRest_Var -- alt acoreAlt = CAlt_Alt -- defaults acoreDfltBoundmeta = (acbaspkeyDefault,0,CLbl_None) acoreTyErr s = acoreTy2ty emptyEHCOpts $ Ty_Dbg s acoreTyNone = acoreTyErr "Core.acoreTyNone" acoreTyChar o = acoreTy2ty o $ tyChar acoreTyInt o = acoreTy2ty o $ tyInt acoreTyString o = acoreTy2ty o $ tyString o -- bindcateg acoreBindcategRec = CBindCateg_Rec acoreBindcategStrict = CBindCateg_Strict acoreBindcategPlain = CBindCateg_Plain -- inspecting acoreExprMbApp (CExpr_App f b) = Just (f,b) acoreExprMbApp _ = Nothing acoreExprMbLam (CExpr_Lam b e) = Just (b,e) acoreExprMbLam _ = Nothing acoreExprMbLet (CExpr_Let c b e) = Just (c,b,e) acoreExprMbLet _ = Nothing acoreExprMbVar (CExpr_Var r) = Just (acbrefNm r) acoreExprMbVar _ = Nothing acoreExprMbInt (CExpr_Int i) = Just (acoreTyErr "Core.acoreExprMbInt",toInteger i) acoreExprMbInt _ = Nothing acoreBindcategMbRec CBindCateg_Rec = Just CBindCateg_Rec acoreBindcategMbRec _ = Nothing acoreBindcategMbStrict CBindCateg_Strict = Just CBindCateg_Strict acoreBindcategMbStrict _ = Nothing acorePatMbCon (CPat_Con tg r fs) = Just (tg,r,fs) acorePatMbCon _ = Nothing acorePatMbInt (CPat_Int i) = Just (acoreTyErr "Core.acorePatMbInt",toInteger i) acorePatMbInt _ = Nothing acorePatMbChar (CPat_Char i) = Just (acoreTyErr "Core.acorePatMbChar",i) acorePatMbChar _ = Nothing acoreUnAlt (CAlt_Alt p e) = (p,e) acoreUnPatFld (CPatFld_Fld l o b _) = ((l,o),b) acoreUnBind (CBind_Bind n as) = (n,as) acoreBoundMbVal (CBound_Val a m l e) = Just ((a,m,l),e) acoreBoundMbVal _ = Nothing -- coercion acoreCoeArg = CExpr_CoeArg acoreExprIsCoeArg = (== CExpr_CoeArg) instance Serialize CModule instance Serialize CExport instance Serialize CImport instance Serialize CDeclMeta instance Serialize CDataCon instance Serialize CExpr instance Serialize CExprAnn instance Serialize CBindAnn instance Serialize CBound instance Serialize CBind instance Serialize CAlt instance Serialize CPat instance Serialize CPatRest instance Serialize CPatFld instance Serialize CBindCateg where sput = sputEnum8 sget = sgetEnum8 -- CAlt -------------------------------------------------------- data CAlt = CAlt_Alt {pat_CAlt_Alt :: !(CPat),expr_CAlt_Alt :: !(CExpr)} deriving ( Eq,Generic,Typeable) -- CAltL ------------------------------------------------------- type CAltL = [CAlt] -- CBind ------------------------------------------------------- data CBind = CBind_Bind {nm_CBind_Bind :: !(HsName),bindAspects_CBind_Bind :: !(CBoundL)} deriving ( Eq,Generic,Typeable) -- CBindAnn ---------------------------------------------------- data CBindAnn = CBindAnn_Coe {coe_CBindAnn_Coe :: !((()))} deriving ( Eq,Generic,Typeable) -- CBindAnnL --------------------------------------------------- type CBindAnnL = [CBindAnn] -- CBindL ------------------------------------------------------ type CBindL = [CBind] -- CBound ------------------------------------------------------ data CBound = CBound_Bind {expr_CBound_Bind :: !(CExpr)} | CBound_Val {aspectKeyS_CBound_Val :: !(ACoreBindAspectKeyS),mlev_CBound_Val :: !(MetaLev),lbl_CBound_Val :: !(CLbl),expr_CBound_Val :: !(CExpr)} | CBound_Ty {aspectKeyS_CBound_Ty :: !(ACoreBindAspectKeyS),ty_CBound_Ty :: !(Ty)} | CBound_FFE {callconv_CBound_FFE :: !(FFIWay),expEnt_CBound_FFE :: !(ForeignEnt),expr_CBound_FFE :: !(CExpr),ty_CBound_FFE :: !(Ty)} deriving ( Eq,Generic,Typeable) -- CBoundL ----------------------------------------------------- type CBoundL = [CBound] -- CDataCon ---------------------------------------------------- data CDataCon = CDataCon_Con {conNm_CDataCon_Con :: !(HsName),tagNr_CDataCon_Con :: !(Int),arity_CDataCon_Con :: !(Int)} deriving ( Generic,Typeable) -- CDataConL --------------------------------------------------- type CDataConL = [CDataCon] -- CDeclMeta --------------------------------------------------- data CDeclMeta = CDeclMeta_Data {tyNm_CDeclMeta_Data :: !(HsName),dataCons_CDeclMeta_Data :: !(CDataConL)} deriving ( Generic,Typeable) -- CDeclMetaL -------------------------------------------------- type CDeclMetaL = [CDeclMeta] -- CExport ----------------------------------------------------- data CExport = CExport_Export {nm_CExport_Export :: !(HsName)} | CExport_ExportData {nm_CExport_ExportData :: !(HsName),mbConNmL_CExport_ExportData :: !((Maybe [HsName]))} deriving ( Eq,Generic,Ord,Typeable) -- CExportL ---------------------------------------------------- type CExportL = [CExport] -- CExpr ------------------------------------------------------- data CExpr = CExpr_Var {ref_CExpr_Var :: !(ACoreBindRef)} | CExpr_Int {int_CExpr_Int :: !(Int)} | CExpr_Char {char_CExpr_Char :: !(Char)} | CExpr_String {str_CExpr_String :: !(String)} | CExpr_Integer {integer_CExpr_Integer :: !(Integer)} | CExpr_Tup {tag_CExpr_Tup :: !(CTag)} | CExpr_Let {categ_CExpr_Let :: !(CBindCateg),binds_CExpr_Let :: !(CBindL),body_CExpr_Let :: !(CExpr)} | CExpr_App {func_CExpr_App :: !(CExpr),arg_CExpr_App :: !(CBound)} | CExpr_Lam {bind_CExpr_Lam :: !(CBind),body_CExpr_Lam :: !(CExpr)} | CExpr_Case {expr_CExpr_Case :: !(CExpr),alts_CExpr_Case :: !(CAltL),dflt_CExpr_Case :: !(CExpr)} | CExpr_CaseAltFail {failReason_CExpr_CaseAltFail :: !(CaseAltFailReason),errorExpr_CExpr_CaseAltFail :: !(CExpr)} | CExpr_TupDel {expr_CExpr_TupDel :: !(CExpr),tag_CExpr_TupDel :: !(CTag),nm_CExpr_TupDel :: !(HsName),offset_CExpr_TupDel :: !(CExpr)} | CExpr_TupIns {expr_CExpr_TupIns :: !(CExpr),tag_CExpr_TupIns :: !(CTag),nm_CExpr_TupIns :: !(HsName),offset_CExpr_TupIns :: !(CExpr),fldExpr_CExpr_TupIns :: !(CExpr)} | CExpr_TupUpd {expr_CExpr_TupUpd :: !(CExpr),tag_CExpr_TupUpd :: !(CTag),nm_CExpr_TupUpd :: !(HsName),offset_CExpr_TupUpd :: !(CExpr),fldExpr_CExpr_TupUpd :: !(CExpr)} | CExpr_FFI {callconv_CExpr_FFI :: !(FFIWay),safety_CExpr_FFI :: !(String),impEnt_CExpr_FFI :: !(ForeignEnt),ty_CExpr_FFI :: !(Ty)} | CExpr_Dbg {info_CExpr_Dbg :: !(String)} | CExpr_Hole {uid_CExpr_Hole :: !(UID)} | CExpr_HoleLet {bindsUid_CExpr_HoleLet :: !(UID),body_CExpr_HoleLet :: !(CExpr)} | CExpr_CoeArg {} | CExpr_ImplsApp {func_CExpr_ImplsApp :: !(CExpr),uid_CExpr_ImplsApp :: !(ImplsVarId)} | CExpr_ImplsLam {uid_CExpr_ImplsLam :: !(ImplsVarId),body_CExpr_ImplsLam :: !(CExpr)} | CExpr_Ann {ann_CExpr_Ann :: !(CExprAnn),expr_CExpr_Ann :: !(CExpr)} deriving ( Eq,Generic,Typeable) -- CExprAnn ---------------------------------------------------- data CExprAnn = CExprAnn_Ty {ty_CExprAnn_Ty :: !(Ty)} | CExprAnn_Debug {info_CExprAnn_Debug :: !(String)} deriving ( Eq,Generic,Typeable) -- CImport ----------------------------------------------------- data CImport = CImport_Import {nm_CImport_Import :: !(HsName)} deriving ( Eq,Generic,Ord,Typeable) -- CImportL ---------------------------------------------------- type CImportL = [CImport] -- CModule ----------------------------------------------------- data CModule = CModule_Mod {moduleNm_CModule_Mod :: !(HsName),exports_CModule_Mod :: !(CExportL),imports_CModule_Mod :: !(CImportL),declMetas_CModule_Mod :: !(CDeclMetaL),expr_CModule_Mod :: !(CExpr)} deriving ( Generic,Typeable) -- CPat -------------------------------------------------------- data CPat = CPat_Var {pnm_CPat_Var :: !(HsName)} | CPat_Con {tag_CPat_Con :: !(CTag),rest_CPat_Con :: !(CPatRest),binds_CPat_Con :: !(CPatFldL)} | CPat_Int {int_CPat_Int :: !(Int)} | CPat_Char {char_CPat_Char :: !(Char)} | CPat_BoolExpr {cexpr_CPat_BoolExpr :: !(CExpr)} deriving ( Eq,Generic,Typeable) -- CPatFld ----------------------------------------------------- data CPatFld = CPatFld_Fld {lbl_CPatFld_Fld :: !(HsName),offset_CPatFld_Fld :: !(CExpr),bind_CPatFld_Fld :: !(CBind),fldAnns_CPatFld_Fld :: !(CBindAnnL)} deriving ( Eq,Generic,Typeable) -- CPatFldL ---------------------------------------------------- type CPatFldL = [CPatFld] -- CPatRest ---------------------------------------------------- data CPatRest = CPatRest_Var {nm_CPatRest_Var :: !(HsName)} | CPatRest_Empty {} deriving ( Eq,Generic,Typeable) -- CodeAGItf --------------------------------------------------- data CodeAGItf = CodeAGItf_AGItf {module_CodeAGItf_AGItf :: !(CModule)} deriving ( Generic,Typeable)