-- UUAGC 0.9.50.2 (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 , CRArray, CRMArray, emptyCRArray, crarrayToList, crarrayFromList, craLength, craAssocs, craAssocs', craReverseAssocs' , Bind , dbgs, dbg , mbSExpr , exp2sexp , RRef (..), noRRef , rrefToDif , Ref2Nm , Nm2RefMp, emptyNm2RefMp, nm2refUnion, nm2RefMpInverse, nm2refLookup , ref2nmEmpty, ref2nmUnion, ref2nmLookup , mkLocLevRef, mkLocDifRef, mkGlobRef, mkImpRef, mkModRef , 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 , rrefToImp, rrefToExp , 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' and 'RRef_Glb' = 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 } -- | 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 level } -- | debug variant, holding original name | RRef_Dbg { rrefNm :: !HsName } deriving (Eq,Ord) 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 -- | 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) = maybe (RRef_Dbg n) (flip RRef_Imp o) $ lkup $ panicJust "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 -- | 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 Binary Mod where put (Mod_Mod a b c d e f g h) = put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h get = liftM8 Mod_Mod get get get get get get get get instance Serialize Mod where sput = sputPlain sget = sgetPlain instance Binary Meta where put (Meta_Data a b) = {- putWord8 0 >> -} put a >> put b get = {- do t <- getWord8 case t of 0 -> -} liftM2 Meta_Data get get instance Binary Import where put (Import_Import a) = {- putWord8 0 >> -} put a get = {- do t <- getWord8 case t of 0 -> -} liftM Import_Import get instance Binary DataCon where put (DataCon_Con a b) = {- putWord8 0 >> -} put a >> put b get = {- do t <- getWord8 case t of 0 -> -} liftM2 DataCon_Con get get instance Binary Exp where put (Exp_SExp a ) = putWord8 0 >> put a put (Exp_Tup a b ) = putWord8 1 >> put a >> put b put (Exp_Let a b c d ) = putWord8 2 >> put a >> put b >> put c >> put d put (Exp_App a b ) = putWord8 3 >> put a >> put b put (Exp_Lam a b c d e ) = putWord8 4 >> put a >> put b >> put c >> put d >> put e put (Exp_Force a ) = putWord8 5 >> put a put (Exp_Tail a ) = putWord8 6 >> put a put (Exp_Case a b ) = putWord8 7 >> put a >> put b put (Exp_FFI a b ) = putWord8 8 >> put a >> put b get = do t <- getWord8 case t of 0 -> liftM Exp_SExp get 1 -> liftM2 Exp_Tup get get 2 -> liftM4 Exp_Let get get get get 3 -> liftM2 Exp_App get get 4 -> liftM5 Exp_Lam get get get get get 5 -> liftM Exp_Force get 6 -> liftM Exp_Tail get 7 -> liftM2 Exp_Case get get 8 -> liftM2 Exp_FFI get get instance Binary SExp where put (SExp_Var a ) = putWord8 0 >> put a put (SExp_Int a ) = putWord8 1 >> put a put (SExp_Char a ) = putWord8 2 >> put a put (SExp_String a ) = putWord8 3 >> put a put (SExp_Integer a ) = putWord8 4 >> put a put (SExp_Dbg a ) = putWord8 5 >> put a get = do t <- getWord8 case t of 0 -> liftM SExp_Var get 1 -> liftM SExp_Int get 2 -> liftM SExp_Char get 3 -> liftM SExp_String get 4 -> liftM SExp_Integer get 5 -> liftM SExp_Dbg get instance Binary Alt where put (Alt_Alt a b) = {- putWord8 0 >> -} put a >> put b get = {- do t <- getWord8 case t of 0 -> -} liftM2 Alt_Alt get get instance Binary Pat where put (Pat_Con a ) = {- putWord8 0 >> -} put a get = {- do t <- getWord8 case t of 0 -> -} liftM Pat_Con get instance Binary RunPrim where put = putEnum get = getEnum instance Binary RRef where put (RRef_Glb a b ) = putWord8 0 >> put a >> put b put (RRef_Loc a b ) = putWord8 1 >> put a >> put b put (RRef_LDf a b ) = putWord8 2 >> put a >> put b put (RRef_Tag a ) = putWord8 3 >> put a put (RRef_Fld a b ) = putWord8 4 >> put a >> put b put (RRef_Dbg a ) = putWord8 5 >> put a put (RRef_Mod a ) = putWord8 6 >> put a put (RRef_Imp a b ) = putWord8 7 >> put a >> put b put (RRef_Exp a b ) = putWord8 8 >> put a >> put b get = do t <- getWord8 case t of 0 -> liftM2 RRef_Glb get get 1 -> liftM2 RRef_Loc get get 2 -> liftM2 RRef_LDf get get 3 -> liftM RRef_Tag get 4 -> liftM2 RRef_Fld get get 5 -> liftM RRef_Dbg get 6 -> liftM RRef_Mod get 7 -> liftM2 RRef_Imp get get 8 -> liftM2 RRef_Exp get get instance Binary a => Binary (CRArray a) where put = put . crarrayToList get = fmap crarrayFromList get -- ************************************** -- 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 current module, using offset mkModRef :: Int -> RRef mkModRef = RRef_Mod -- ************************************** -- 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 mkModWithImportsMetas :: HsName -- ^ module name -> Int -- ^ module number -> 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 = Mod_Mod ref2nmEmpty modNm modNr stkDepth imports metas binds body -- | Module, with meta info mkModWithMetas :: HsName -- ^ module name -> Int -- ^ module number -> 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 -> Int -- ^ module number -> 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 -> Int -- ^ module number -> 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)} -- Alt --------------------------------------------------------- data Alt = Alt_Alt {ref2nm_Alt_Alt :: !(Ref2Nm),expr_Alt_Alt :: !(Exp)} -- DataCon ----------------------------------------------------- data DataCon = DataCon_Con {conNm_DataCon_Con :: !(HsName),tagNr_DataCon_Con :: !(Int)} -- 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))} -- Import ------------------------------------------------------ data Import = Import_Import {nm_Import_Import :: !(HsName)} -- ImportL ----------------------------------------------------- type ImportL = [Import] -- MbExp ------------------------------------------------------- type MbExp = Maybe (Exp) -- Meta -------------------------------------------------------- data Meta = Meta_Data {tyNm_Meta_Data :: !(HsName),dataCons_Meta_Data :: !(DataConL)} -- MetaL ------------------------------------------------------- type MetaL = [Meta] -- Mod --------------------------------------------------------- data Mod = Mod_Mod {ref2nm_Mod_Mod :: !(Ref2Nm),moduleNm_Mod_Mod :: !(HsName),moduleNr_Mod_Mod :: !(Int),stkDepth_Mod_Mod :: !(Int),imports_Mod_Mod :: !(ImportL),metas_Mod_Mod :: !(MetaL),binds_Mod_Mod :: !((CRArray Bind)),mbbody_Mod_Mod :: !(MbExp)} -- Pat --------------------------------------------------------- data Pat = Pat_Con {tag_Pat_Con :: !(Int)} -- 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)}