uhc-light-1.1.9.3: src/UHC/Light/Compiler/Core.hs
-- UUAGC 0.9.52.2 (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)