-- UUAGC 0.9.52.1 (build/103/lib-ehc/UHC/Light/Compiler/CoreRun.ag) module UHC.Light.Compiler.CoreRun(module UHC.Light.Compiler.CoreRun.Prim , AGItf (..) , Mod (..), SExp (..), Exp (..), MbExp, Alt (..), Pat (..) , Meta (..), MetaL, DataCon (..), DataConL, Import (..), ImportL, Export (..), ExportL , CRArray, CRMArray, emptyCRArray, crarrayToList, crarrayFromList, craLength, craAssocs, craAssocs', craReverseAssocs' , Bind , dbgs, dbg , mbSExpr , exp2sexp , RRef (..), noRRef , rrefResolve , rrefToDif , Ref2Nm , Nm2RefMp, emptyNm2RefMp, nm2refUnion, nm2RefMpInverse, nm2refLookup , ref2nmEmpty, ref2nmUnion, ref2nmLookup , mkLocLevRef, mkLocDifRef, mkGlobRef, mkImpRef, mkExpRef, mkModRef, mkTagRef, mkFldRef , mkExp, mkVar, mkVar', mkInt, mkInt', mkChar, mkChar', mkString, mkString' , mkDbg, mkDbg' , mkApp, mkApp', mkTup, mkTup', mkEval, mkTail, mkCase, mkLam, mkLam', mkLet, mkLet', mkFFI, mkFFI' , mkImport , mkMetaDataCon, mkMetaDataType , mkMod, mkMod', mkModWithMetas, mkModWithImportsMetas, mkModWithImportsExportsMetas , rrefToImp, rrefToExp, rrefResolveUnr , mkInteger, mkInteger') where import UHC.Light.Compiler.Base.Common import UHC.Light.Compiler.Base.Target import UHC.Util.Utils import qualified UHC.Util.RelMap as Rel import UHC.Light.Compiler.Ty import qualified Data.Map as Map import Data.Maybe import Data.Char import Data.List import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import Control.Applicative import UHC.Light.Compiler.CoreRun.Prim import Control.Monad import UHC.Util.Binary import UHC.Util.Serialize import UHC.Light.Compiler.Foreign deriving instance Typeable Mod -- | Fast access sequence type CRArray x = V.Vector x type CRMArray x = MV.IOVector x -- | Wrapper (rename) around vector<->list conversion crarrayFromList :: [x] -> CRArray x -- crarrayFromList = mkCRArrayLwb 0 crarrayFromList = V.fromList {-# INLINE crarrayFromList #-} -- | Wrapper (rename) around vector<->list conversion crarrayToList :: CRArray x -> [x] crarrayToList = V.toList {-# INLINE crarrayToList #-} emptyCRArray :: CRArray x emptyCRArray = V.empty -- mkCRArray [] {-# INLINE emptyCRArray #-} craLength :: CRArray x -> Int craLength = V.length -- a = h + 1 - l -- where (l,h) = bounds a {-# INLINE craLength #-} -- | Content of array as association list, starting index at 'lwb' craAssocs' :: Int -> CRArray x -> [(Int,x)] craAssocs' lwb = zip [lwb ..] . crarrayToList {-# INLINE craAssocs' #-} -- | Content of array as association list, starting index at 'lwb', but reversed craReverseAssocs' :: Int -> CRArray x -> [(Int,x)] craReverseAssocs' lwb v = zip [hi, hi-1 ..] $ V.toList v where hi = lwb + V.length v - 1 {-# INLINE craReverseAssocs' #-} -- | Content of array as association list, starting index at 0 craAssocs :: CRArray x -> [(Int,x)] craAssocs = craAssocs' 0 {-# INLINE craAssocs #-} -- | Bind, just an Exp, addressing is left implicit type Bind = Exp -- | Equivalent of '()' unit :: Exp unit = Exp_Tup 0 emptyCRArray -- | Debug info is embedded in SExp dbgs = SExp_Dbg dbg = Exp_SExp . dbgs -- | Is exp a SExp? mbSExpr :: Exp -> Maybe SExp mbSExpr (Exp_SExp s) = Just s mbSExpr _ = Nothing -- | Convert to SExp exp2sexp :: Exp -> SExp exp2sexp = maybe (dbgs "CoreRun.exp2sexp") id . mbSExpr -- | Identifier references for use during running CoreRun data RRef -- | global reference to module and its entry, will become obsolete, to be replaced by 'RRef_Mod', 'RRef_Exp', and RRef_Imp = RRef_Glb { rrefMod :: !Int -- ^ module , rrefEntry :: !Int -- ^ entry inside module } -- | entry of current module reference | RRef_Mod { rrefEntry :: !Int -- ^ entry inside module, in its frame } -- | Unresolved entry, to be resolved to a RRef_Imp (most likely) | RRef_Unr { rrefNm :: !HsName -- ^ module name, to be looked up in a module specific import list for an index } -- | exported entry of module reference, only used internally to be later resolved to a 'RRef_Imp' | RRef_Exp { rrefModNm :: !HsName -- ^ module name, to be looked up in a module specific import list for an index , rrefEntry :: !Int -- ^ entry inside module, in its frame } -- | imported entry of module reference | RRef_Imp { rrefMod :: !Int -- ^ module (sequence) nr as it appears in the imported module list , rrefEntry :: !Int -- ^ entry inside module, in its frame } -- | local reference to on stack value, not interpreted during running, if used must be converted with 'rrefToDif' before running; may become obsolete. | RRef_Loc { rrefLev :: !Int -- ^ level when used statically , rrefEntry :: !Int -- ^ entry inside level } -- | local reference to on stack value, but measured relative to level of from where is referenced, used at runtime | RRef_LDf { rrefLevDiff :: !Int -- ^ offset/difference in levels when used at runtime , rrefEntry :: !Int -- ^ entry inside level } -- | tag of memory/constructor node referred to by other ref | RRef_Tag { rrefRef :: !RRef -- ^ of what this is the tag } -- | fld of memory/constructor node referred to by other ref | RRef_Fld { rrefRef :: !RRef -- ^ of what this is a field , rrefEntry :: !Int -- ^ entry inside node, zero base index } -- | debug variant, holding original name | RRef_Dbg { rrefNm :: !HsName } deriving (Eq,Ord,Generic) instance Show RRef where show _ = "RRef" noRRef = RRef_Dbg hsnUnknown -- | Map over the non-recursive parts of RRef mapRRef :: (RRef -> RRef) -> RRef -> RRef mapRRef f r@(RRef_Fld {rrefRef=r'}) = r {rrefRef = mapRRef f r'} mapRRef f r@(RRef_Tag {rrefRef=r'}) = r {rrefRef = mapRRef f r'} mapRRef f r = f r -- | Resolve as far as possible rrefResolve :: Maybe Int -> Maybe (HsName -> Maybe Int) -> Nm2RefMp -> HsName -> RRef rrefResolve mbLev mbImpNmLkup nm2ref nm = maybe (RRef_Unr nm) ( maybe id rrefToDif mbLev . maybe id rrefToImp mbImpNmLkup ) $ nm2refLookup nm nm2ref -- | Convert to RRef_Exp to RRef_Imp, i.e. named module to indexed module ref rrefToImp :: (HsName -> Maybe Int) -> RRef -> RRef rrefToImp lkup = mapRRef f where f r@(RRef_Exp n o) = fromMaybe r $ {- hsnQualifier n >>= -} lkup n >>= (return . flip RRef_Imp o) -- maybe r (flip RRef_Imp o) $ lkup $ panicJust "CoreRun.rrefToImp" $ hsnQualifier n f r = r -- | Convert to RRef_Mod to RRef_Exp, i.e. local module ref to exported rrefToExp :: HsName -> RRef -> RRef rrefToExp nm = mapRRef f where f r@(RRef_Mod o) = RRef_Exp nm o f r = r -- | Resolve RRef_Unr rrefResolveUnr :: Maybe (HsName -> Maybe Int) -> Nm2RefMp -> RRef -> RRef rrefResolveUnr mbImpNmLkup nm2ref = mapRRef f where f r@(RRef_Unr n) = rrefResolve Nothing mbImpNmLkup nm2ref n f r = r -- | Convert to RRef_Loc to RRef_LDf, i.e. absolute level to relative (to current) level rrefToDif :: Int -> RRef -> RRef rrefToDif curlev = mapRRef f where f r@(RRef_Loc l o) = RRef_LDf (curlev - l) o f r = r {- rrefToDif curlev r@(RRef_Loc l o ) = RRef_LDf (curlev - l) o rrefToDif curlev r@(RRef_Fld {rrefRef=r'}) = r {rrefRef = rrefToDif curlev r'} rrefToDif curlev r@(RRef_Tag {rrefRef=r'}) = r {rrefRef = rrefToDif curlev r'} rrefToDif _ r = r -} -- | RRef to HsName mapping for use during running when a more informative name is required. -- The representation is lazily via function type Nm2RefRel = Rel.Rel HsName RRef -- RRef -> Maybe HsName -- | RRef to HsName mapping for use during running when a more informative name is required. -- The representation is lazily via function type Ref2Nm = Nm2RefRel -- RRef -> Maybe HsName -- | HsName to RRef mapping for resolving references during translation to CoreRun type Nm2RefMp = Nm2RefRel -- Map.Map HsName RRef emptyNm2RefMp :: Nm2RefMp emptyNm2RefMp = Rel.empty -- Map.empty nm2refUnion :: Nm2RefMp -> Nm2RefMp -> Nm2RefMp nm2refUnion = Rel.union -- Map.union nm2refLookup :: HsName -> Nm2RefMp -> Maybe RRef nm2refLookup = Rel.lookup -- | Inverse of a `Nm2RefMp` nm2RefMpInverse :: Nm2RefMp -> Ref2Nm nm2RefMpInverse m = m {- | Map.null m = const Nothing | otherwise = flip Map.lookup inv where inv = Map.fromList [ (r,n) | (n,r) <- Map.toList m ] -} -- | Empty Ref2Nm ref2nmEmpty :: Ref2Nm ref2nmEmpty = Rel.empty -- const Nothing ref2nmLookup :: RRef -> Ref2Nm -> Maybe HsName ref2nmLookup = Rel.lookupInverse -- | Union, left-biased ref2nmUnion :: Ref2Nm -> Ref2Nm -> Ref2Nm ref2nmUnion = Rel.union -- m1 m2 = \r -> m1 r <|> m2 r instance Serialize Mod where sput = sputPlain sget = sgetPlain instance Binary RunPrim where put = putEnum get = getEnum instance Binary a => Binary (CRArray a) where put = put . crarrayToList get = fmap crarrayFromList get instance Binary Mod instance Binary Meta instance Binary Import instance Binary Export instance Binary DataCon instance Binary Exp instance Binary SExp instance Binary Alt instance Binary Pat instance Binary RRef -- ************************************** -- Construction: references -- ************************************** -- | 'RRef' to local or outside scoped, using absolute level and offset (this is to be converted to a level difference + offset encoding for running, see 'mkLocDifRef') mkLocLevRef :: Int -> Int -> RRef mkLocLevRef = RRef_Loc -- | 'RRef' to local or outside scoped, using level difference (to a current) and offset mkLocDifRef :: Int -> Int -> RRef mkLocDifRef = RRef_LDf -- | 'RRef' to global from module, using module nr and offset (will become obsolete, replaced by either Imp or Mod Ref mkGlobRef :: Int -> Int -> RRef mkGlobRef = RRef_Glb -- | 'RRef' to global from module, using module nr and offset mkImpRef :: Int -> Int -> RRef mkImpRef = RRef_Imp -- | 'RRef' to global from module, using module name and offset mkExpRef :: HsName -> Int -> RRef mkExpRef = RRef_Exp -- | 'RRef' to global from current module, using offset mkModRef :: Int -> RRef mkModRef = RRef_Mod -- | 'RRef' to tag of node mkTagRef :: RRef -> RRef mkTagRef = RRef_Tag -- | 'RRef' to field of node, using a zero based index mkFldRef :: RRef -> Int -> RRef mkFldRef = RRef_Fld -- ************************************** -- Construction: constants as SExp or Exp -- ************************************** -- | Lift 'SExp' into 'Exp' mkExp :: SExp -> Exp mkExp = Exp_SExp -- | Var ref as 'SExp' mkVar' :: RRef -> SExp mkVar' = SExp_Var -- | Var ref as 'Exp' mkVar :: RRef -> Exp mkVar = mkExp . mkVar' -- | Int constant as 'SExp' mkInt' :: Int -> SExp mkInt' = SExp_Int -- | Int constant as 'Exp' mkInt :: Int -> Exp mkInt = mkExp . mkInt' -- | Char constant as 'SExp' mkChar' :: Char -> SExp mkChar' = SExp_Char -- | Char constant as 'Exp' mkChar :: Char -> Exp mkChar = mkExp . mkChar' -- | String constant as 'SExp' mkString' :: String -> SExp mkString' = SExp_String -- | String constant as 'Exp' mkString :: String -> Exp mkString = mkExp . mkString' -- | Debug info as 'SExp', will make an interpreter stop with displaying the message mkDbg' :: String -> SExp mkDbg' = dbgs -- | Debug info as 'Exp' mkDbg :: String -> Exp mkDbg = dbg -- | Integer constant as 'SExp' mkInteger' :: Integer -> SExp mkInteger' = SExp_Integer -- | Integer constant as 'Exp' mkInteger :: Integer -> Exp mkInteger = mkExp . mkInteger' -- ************************************** -- Construction: Exp -- ************************************** -- | Application mkApp' :: Exp -> CRArray SExp -> Exp mkApp' = Exp_App -- | Application mkApp :: Exp -> [SExp] -> Exp mkApp f as = mkApp' f (crarrayFromList as) -- | Tuple, Node mkTup' :: Int -> CRArray SExp -> Exp mkTup' = Exp_Tup -- | Tuple, Node mkTup :: Int -> [SExp] -> Exp mkTup t as = mkTup' t (crarrayFromList as) -- | Force evaluation mkEval :: Exp -> Exp mkEval = Exp_Force -- | Set tail call context mkTail :: Exp -> Exp mkTail = Exp_Tail -- | Case mkCase :: SExp -> [Exp] -> Exp mkCase scrut alts = Exp_Case scrut $ crarrayFromList $ map (Alt_Alt ref2nmEmpty) alts -- | Lambda mkLam' :: Maybe HsName -- ^ a name for this lambda, to be used for pretty printing -> Int -- ^ nr of arguments, 0 encodes a thunk/CAF -> Int -- ^ total stack size, including arguments, locals, expression calculation -> Exp -- ^ body -> Exp mkLam' mbNm nrArgs stackDepth body = Exp_Lam mbNm nrArgs stackDepth ref2nmEmpty body -- | Lambda mkLam :: Int -- ^ nr of arguments, 0 encodes a thunk/CAF -> Int -- ^ total stack size, including arguments, locals, expression calculation -> Exp -- ^ body -> Exp mkLam nrArgs stackDepth body = mkLam' Nothing nrArgs stackDepth body -- | Let mkLet' :: Int -- ^ stackoffset to place bound value -> CRArray Exp -- ^ bound terms -> Exp -- ^ body -> Exp mkLet' firstoff bs b = Exp_Let firstoff ref2nmEmpty bs b -- | Let mkLet :: Int -- ^ stackoffset to place bound value -> [Exp] -- ^ bound terms -> Exp -- ^ body -> Exp mkLet firstoff bs b = mkLet' firstoff (crarrayFromList bs) b -- | FFI mkFFI' :: String -- ^ name of foreign entity, if unknown results in debug expr -> CRArray SExp -- ^ args -> Exp mkFFI' fe as = case Map.lookup fe allRunPrimMp of Just p -> Exp_FFI p as _ -> dbg $ "CoreRun.mkFFI: " ++ fe -- | FFI mkFFI :: String -- ^ name of foreign entity, if unknown results in debug expr -> [SExp] -- ^ args -> Exp mkFFI fe as = mkFFI' fe (crarrayFromList as) -- ************************************** -- Construction: Import -- ************************************** -- | Meta: datatype constructor info mkImport :: HsName -- ^ name of imported module -> Import mkImport = Import_Import -- ************************************** -- Construction: Meta info -- ************************************** -- | Meta: datatype constructor info mkMetaDataCon :: HsName -- ^ constructor name (without module qualifier, name must be globally unique) -> Int -- ^ constructor tag -> DataCon mkMetaDataCon = DataCon_Con -- | Meta: datatype constructor info mkMetaDataType :: HsName -- ^ datatype name (fully qualified) -> [DataCon] -- ^ constructor tag -> Meta mkMetaDataType = Meta_Data -- ************************************** -- Construction: Top level module -- ************************************** -- | Module, with imports, with meta info mkModWithImportsExportsMetas :: HsName -- ^ module name -> Maybe Int -- ^ module number, possibly (to become obsolete) -> Int -- ^ total stack size, including globals of module, their setup (see semantics), and the main startup part kicking of evaluation -> [Import] -- ^ imports -> [Export] -- ^ exports -> [Meta] -- ^ meta info -> CRArray Bind -- ^ bound expressions -> Maybe Exp -- ^ body of main, absence of main indicated by Nothing -> Mod mkModWithImportsExportsMetas modNm modNr stkDepth imports exports metas binds body = Mod_Mod ref2nmEmpty modNm modNr stkDepth imports exports metas binds body -- | Module, with imports, with meta info mkModWithImportsMetas :: HsName -- ^ module name -> Maybe Int -- ^ module number, possibly (to become obsolete) -> Int -- ^ total stack size, including globals of module, their setup (see semantics), and the main startup part kicking of evaluation -> [Import] -- ^ imports -> [Meta] -- ^ meta info -> CRArray Bind -- ^ bound expressions -> Maybe Exp -- ^ body of main, absence of main indicated by Nothing -> Mod mkModWithImportsMetas modNm modNr stkDepth imports metas binds body = mkModWithImportsExportsMetas modNm modNr stkDepth imports [] metas binds body -- | Module, with meta info mkModWithMetas :: HsName -- ^ module name -> Maybe Int -- ^ module number, possibly (to become obsolete) -> Int -- ^ total stack size, including globals of module, their setup (see semantics), and the main startup part kicking of evaluation -> [Meta] -- ^ meta info -> CRArray Bind -- ^ bound expressions -> Exp -- ^ body of main -> Mod mkModWithMetas modNm modNr stkDepth metas binds body = mkModWithImportsMetas modNm modNr stkDepth [] metas binds (Just body) -- | Module mkMod' :: HsName -- ^ module name -> Maybe Int -- ^ module number, possibly (to become obsolete) -> Int -- ^ total stack size, including globals of module, their setup (see semantics), and the main startup part kicking of evaluation -> CRArray Bind -- ^ bound expressions -> Exp -- ^ body of main -> Mod mkMod' modNm modNr stkDepth binds body = mkModWithMetas modNm modNr stkDepth [] binds body -- | Module mkMod :: HsName -- ^ module name -> Maybe Int -- ^ module number, possibly (to become obsolete) -> Int -- ^ total stack size, including globals of module, their setup (see semantics), and the main startup part kicking of evaluation -> [Bind] -- ^ bound expressions -> Exp -- ^ body of main -> Mod mkMod modNm modNr stkDepth binds body = mkMod' modNm modNr stkDepth (crarrayFromList binds) body -- AGItf ------------------------------------------------------- data AGItf = AGItf_AGItf {module_AGItf_AGItf :: !(Mod)} deriving ( Generic) -- Alt --------------------------------------------------------- data Alt = Alt_Alt {ref2nm_Alt_Alt :: !(Ref2Nm),expr_Alt_Alt :: !(Exp)} deriving ( Generic) -- DataCon ----------------------------------------------------- data DataCon = DataCon_Con {conNm_DataCon_Con :: !(HsName),tagNr_DataCon_Con :: !(Int)} deriving ( Generic) -- DataConL ---------------------------------------------------- type DataConL = [DataCon] -- Exp --------------------------------------------------------- data Exp = Exp_SExp {sexpr_Exp_SExp :: !(SExp)} | Exp_Tup {tag_Exp_Tup :: !(Int),args_Exp_Tup :: !((CRArray SExp))} | Exp_Let {firstOff_Exp_Let :: !(Int),ref2nm_Exp_Let :: !(Ref2Nm),binds_Exp_Let :: !((CRArray Bind)),body_Exp_Let :: !(Exp)} | Exp_App {func_Exp_App :: !(Exp),args_Exp_App :: !((CRArray SExp))} | Exp_Lam {mbNm_Exp_Lam :: !((Maybe HsName)),nrArgs_Exp_Lam :: !(Int),stkDepth_Exp_Lam :: !(Int),ref2nm_Exp_Lam :: !(Ref2Nm),body_Exp_Lam :: !(Exp)} | Exp_Force {expr_Exp_Force :: !(Exp)} | Exp_Tail {expr_Exp_Tail :: !(Exp)} | Exp_Case {expr_Exp_Case :: !(SExp),alts_Exp_Case :: !((CRArray Alt))} | Exp_FFI {prim_Exp_FFI :: !(RunPrim),args_Exp_FFI :: !((CRArray SExp))} deriving ( Generic) -- Export ------------------------------------------------------ data Export = Export_Export {nm_Export_Export :: !(HsName),offset_Export_Export :: !(Int)} deriving ( Generic) -- ExportL ----------------------------------------------------- type ExportL = [Export] -- Import ------------------------------------------------------ data Import = Import_Import {nm_Import_Import :: !(HsName)} deriving ( Generic) -- ImportL ----------------------------------------------------- type ImportL = [Import] -- MbExp ------------------------------------------------------- type MbExp = Maybe (Exp) -- Meta -------------------------------------------------------- data Meta = Meta_Data {tyNm_Meta_Data :: !(HsName),dataCons_Meta_Data :: !(DataConL)} deriving ( Generic) -- MetaL ------------------------------------------------------- type MetaL = [Meta] -- Mod --------------------------------------------------------- data Mod = Mod_Mod {ref2nm_Mod_Mod :: !(Ref2Nm),moduleNm_Mod_Mod :: !(HsName),moduleNr_Mod_Mod :: !((Maybe Int)),stkDepth_Mod_Mod :: !(Int),imports_Mod_Mod :: !(ImportL),exports_Mod_Mod :: !(ExportL),metas_Mod_Mod :: !(MetaL),binds_Mod_Mod :: !((CRArray Bind)),mbbody_Mod_Mod :: !(MbExp)} deriving ( Generic) -- Pat --------------------------------------------------------- data Pat = Pat_Con {tag_Pat_Con :: !(Int)} deriving ( Generic) -- SExp -------------------------------------------------------- data SExp = SExp_Var {ref_SExp_Var :: !(RRef)} | SExp_Int {int_SExp_Int :: !(Int)} | SExp_Char {char_SExp_Char :: !(Char)} | SExp_String {str_SExp_String :: !(String)} | SExp_Integer {integer_SExp_Integer :: !(Integer)} | SExp_Dbg {msg_SExp_Dbg :: !(String)} deriving ( Generic)