module UHC.Light.Compiler.CoreRun(module UHC.Light.Compiler.CoreRun.Prim
, Mod (..), SExp (..), Exp (..), Alt (..), Pat (..)
, CRArray, CRMArray, emptyCRArray, crarrayToList, crarrayFromList, craLength, craAssocs, craAssocs', craReverseAssocs'
, Bind
, dbgs, dbg
, mbSExpr
, exp2sexp
, RRef (..), noRRef
, rrefToDif
, Ref2Nm
, Nm2RefMp, nm2RefMpInverse, ref2nmEmpty, ref2nmUnion
, mkLocLevRef, mkLocDifRef, mkGlobRef
, mkExp, mkVar, mkVar', mkInt, mkInt', mkChar, mkChar', mkString, mkString'
, mkDbg, mkDbg'
, mkApp, mkApp', mkTup, mkTup', mkEval, mkTail, mkCase, mkLam, mkLam', mkLet, mkLet', mkFFI, mkFFI'
, mkMod, mkMod'
, mkInteger, mkInteger') where
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Base.Target
import UHC.Util.Utils
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 UHC.Light.Compiler.Foreign
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_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
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
type Ref2Nm = RRef -> Maybe HsName
type Nm2RefMp = Map.Map HsName RRef
nm2RefMpInverse :: Nm2RefMp -> Ref2Nm
nm2RefMpInverse m
| Map.null m = const Nothing
| otherwise = flip Map.lookup inv
where inv = Map.fromList [ (r,n) | (n,r) <- Map.toList m ]
ref2nmEmpty :: Ref2Nm
ref2nmEmpty = const Nothing
ref2nmUnion :: Ref2Nm -> Ref2Nm -> Ref2Nm
ref2nmUnion m1 m2 = \r -> m1 r <|> m2 r
mkLocLevRef :: Int -> Int -> RRef
mkLocLevRef = RRef_Loc
mkLocDifRef :: Int -> Int -> RRef
mkLocDifRef = RRef_LDf
mkGlobRef :: Int -> Int -> RRef
mkGlobRef = RRef_Glb
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)
mkMod'
:: HsName
-> Int
-> Int
-> CRArray Bind
-> Exp
-> Mod
mkMod' modNm modNr stkDepth binds body = Mod_Mod ref2nmEmpty 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 Alt = Alt_Alt {ref2nm_Alt_Alt :: !(Ref2Nm),expr_Alt_Alt :: !(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))}
data Mod = Mod_Mod {ref2nm_Mod_Mod :: !(Ref2Nm),moduleNm_Mod_Mod :: !(HsName),moduleNr_Mod_Mod :: !(Int),stkDepth_Mod_Mod :: !(Int),binds_Mod_Mod :: !((CRArray Bind)),body_Mod_Mod :: !(Exp)}
data Pat = Pat_Con {tag_Pat_Con :: !(Int)}
| Pat_BoolExpr {expr_Pat_BoolExpr :: !(Exp)}
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)}