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
type CRArray x = V.Vector x
type CRMArray x = MV.IOVector x
crarrayFromList :: [x] -> CRArray x
crarrayFromList = V.fromList
crarrayToList :: CRArray x -> [x]
crarrayToList = V.toList
emptyCRArray :: CRArray x
emptyCRArray = V.empty
craLength :: CRArray x -> Int
craLength = V.length
craAssocs' :: Int -> CRArray x -> [(Int,x)]
craAssocs' lwb = zip [lwb ..] . crarrayToList
craReverseAssocs' :: Int -> CRArray x -> [(Int,x)]
craReverseAssocs' lwb v = zip [hi, hi1 ..] $ V.toList v
where hi = lwb + V.length v 1
craAssocs :: CRArray x -> [(Int,x)]
craAssocs = craAssocs' 0
type Bind = Exp
unit :: Exp
unit = Exp_Tup 0 emptyCRArray
dbgs = SExp_Dbg
dbg = Exp_SExp . dbgs
mbSExpr :: Exp -> Maybe SExp
mbSExpr (Exp_SExp s) = Just s
mbSExpr _ = Nothing
exp2sexp :: Exp -> SExp
exp2sexp = maybe (dbgs "CoreRun.exp2sexp") id . mbSExpr
data RRef
= RRef_Glb
{ rrefMod :: !Int
, rrefEntry :: !Int
}
| RRef_Mod
{ rrefEntry :: !Int
}
| RRef_Exp
{ rrefModNm :: !HsName
, rrefEntry :: !Int
}
| RRef_Imp
{ rrefMod :: !Int
, rrefEntry :: !Int
}
| RRef_Loc
{ rrefLev :: !Int
, rrefEntry :: !Int
}
| RRef_LDf
{ rrefLevDiff :: !Int
, rrefEntry :: !Int
}
| RRef_Tag
{ rrefRef :: !RRef
}
| RRef_Fld
{ rrefRef :: !RRef
, rrefEntry :: !Int
}
| RRef_Dbg
{ rrefNm :: !HsName
}
deriving (Eq,Ord)
instance Show RRef where
show _ = "RRef"
noRRef = RRef_Dbg hsnUnknown
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
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
rrefToExp :: HsName -> RRef -> RRef
rrefToExp nm = mapRRef f
where f r@(RRef_Mod o) = RRef_Exp nm o
f r = r
rrefToDif :: Int -> RRef -> RRef
rrefToDif curlev = mapRRef f
where f r@(RRef_Loc l o) = RRef_LDf (curlev l) o
f r = r
type Nm2RefRel = Rel.Rel HsName RRef
type Ref2Nm = Nm2RefRel
type Nm2RefMp = Nm2RefRel
emptyNm2RefMp :: Nm2RefMp
emptyNm2RefMp = Rel.empty
nm2refUnion :: Nm2RefMp -> Nm2RefMp -> Nm2RefMp
nm2refUnion = Rel.union
nm2refLookup :: HsName -> Nm2RefMp -> Maybe RRef
nm2refLookup = Rel.lookup
nm2RefMpInverse :: Nm2RefMp -> Ref2Nm
nm2RefMpInverse m = m
ref2nmEmpty :: Ref2Nm
ref2nmEmpty = Rel.empty
ref2nmLookup :: RRef -> Ref2Nm -> Maybe HsName
ref2nmLookup = Rel.lookupInverse
ref2nmUnion :: Ref2Nm -> Ref2Nm -> Ref2Nm
ref2nmUnion = Rel.union
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) = put a >> put b
get = liftM2 Meta_Data get get
instance Binary Import where
put (Import_Import a) = put a
get = liftM Import_Import get
instance Binary DataCon where
put (DataCon_Con a b) = put a >> put b
get = 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) = put a >> put b
get = liftM2 Alt_Alt get get
instance Binary Pat where
put (Pat_Con a ) = put a
get = 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
mkLocLevRef :: Int -> Int -> RRef
mkLocLevRef = RRef_Loc
mkLocDifRef :: Int -> Int -> RRef
mkLocDifRef = RRef_LDf
mkGlobRef :: Int -> Int -> RRef
mkGlobRef = RRef_Glb
mkImpRef :: Int -> Int -> RRef
mkImpRef = RRef_Imp
mkModRef :: Int -> RRef
mkModRef = RRef_Mod
mkExp :: SExp -> Exp
mkExp = Exp_SExp
mkVar' :: RRef -> SExp
mkVar' = SExp_Var
mkVar :: RRef -> Exp
mkVar = mkExp . mkVar'
mkInt' :: Int -> SExp
mkInt' = SExp_Int
mkInt :: Int -> Exp
mkInt = mkExp . mkInt'
mkChar' :: Char -> SExp
mkChar' = SExp_Char
mkChar :: Char -> Exp
mkChar = mkExp . mkChar'
mkString' :: String -> SExp
mkString' = SExp_String
mkString :: String -> Exp
mkString = mkExp . mkString'
mkDbg' :: String -> SExp
mkDbg' = dbgs
mkDbg :: String -> Exp
mkDbg = dbg
mkInteger' :: Integer -> SExp
mkInteger' = SExp_Integer
mkInteger :: Integer -> Exp
mkInteger = mkExp . mkInteger'
mkApp' :: Exp -> CRArray SExp -> Exp
mkApp' = Exp_App
mkApp :: Exp -> [SExp] -> Exp
mkApp f as = mkApp' f (crarrayFromList as)
mkTup' :: Int -> CRArray SExp -> Exp
mkTup' = Exp_Tup
mkTup :: Int -> [SExp] -> Exp
mkTup t as = mkTup' t (crarrayFromList as)
mkEval :: Exp -> Exp
mkEval = Exp_Force
mkTail :: Exp -> Exp
mkTail = Exp_Tail
mkCase :: SExp -> [Exp] -> Exp
mkCase scrut alts = Exp_Case scrut $ crarrayFromList $ map (Alt_Alt ref2nmEmpty) alts
mkLam'
:: Maybe HsName
-> Int
-> Int
-> Exp
-> Exp
mkLam' mbNm nrArgs stackDepth body = Exp_Lam mbNm nrArgs stackDepth ref2nmEmpty body
mkLam
:: Int
-> Int
-> Exp
-> Exp
mkLam nrArgs stackDepth body = mkLam' Nothing nrArgs stackDepth body
mkLet'
:: Int
-> CRArray Exp
-> Exp
-> Exp
mkLet' firstoff bs b = Exp_Let firstoff ref2nmEmpty bs b
mkLet
:: Int
-> [Exp]
-> Exp
-> Exp
mkLet firstoff bs b = mkLet' firstoff (crarrayFromList bs) b
mkFFI'
:: String
-> CRArray SExp
-> Exp
mkFFI' fe as = case Map.lookup fe allRunPrimMp of
Just p -> Exp_FFI p as
_ -> dbg $ "CoreRun.mkFFI: " ++ fe
mkFFI
:: String
-> [SExp]
-> Exp
mkFFI fe as = mkFFI' fe (crarrayFromList as)
mkImport
:: HsName
-> Import
mkImport = Import_Import
mkMetaDataCon
:: HsName
-> Int
-> DataCon
mkMetaDataCon = DataCon_Con
mkMetaDataType
:: HsName
-> [DataCon]
-> Meta
mkMetaDataType = Meta_Data
mkModWithImportsMetas
:: HsName
-> Int
-> Int
-> [Import]
-> [Meta]
-> CRArray Bind
-> Maybe Exp
-> Mod
mkModWithImportsMetas modNm modNr stkDepth imports metas binds body = Mod_Mod ref2nmEmpty modNm modNr stkDepth imports metas binds body
mkModWithMetas
:: HsName
-> Int
-> Int
-> [Meta]
-> CRArray Bind
-> Exp
-> Mod
mkModWithMetas modNm modNr stkDepth metas binds body = mkModWithImportsMetas modNm modNr stkDepth [] metas binds (Just body)
mkMod'
:: HsName
-> Int
-> Int
-> CRArray Bind
-> Exp
-> Mod
mkMod' modNm modNr stkDepth binds body = mkModWithMetas modNm modNr stkDepth [] binds body
mkMod
:: HsName
-> Int
-> Int
-> [Bind]
-> Exp
-> Mod
mkMod modNm modNr stkDepth binds body = mkMod' modNm modNr stkDepth (crarrayFromList binds) body
data AGItf = AGItf_AGItf {module_AGItf_AGItf :: !(Mod)}
data Alt = Alt_Alt {ref2nm_Alt_Alt :: !(Ref2Nm),expr_Alt_Alt :: !(Exp)}
data DataCon = DataCon_Con {conNm_DataCon_Con :: !(HsName),tagNr_DataCon_Con :: !(Int)}
type DataConL = [DataCon]
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))}
data Import = Import_Import {nm_Import_Import :: !(HsName)}
type ImportL = [Import]
type MbExp = Maybe (Exp)
data Meta = Meta_Data {tyNm_Meta_Data :: !(HsName),dataCons_Meta_Data :: !(DataConL)}
type MetaL = [Meta]
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)}
data Pat = Pat_Con {tag_Pat_Con :: !(Int)}
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)}