module SSTG.Core.Translation.Haskell
( mkCompileClosure
, mkTargetBindings
, mkIOStr
) where
import qualified SSTG.Core.Syntax.Language as SL
import Coercion
import CorePrep
import CoreSyn
import CoreToStg
import DataCon
import FastString
import GHC
import GHC.Paths
import HscTypes
import Literal
import Name
import Outputable
import Pair
import PrimOp
import StgSyn
import TyCon
import TyCoRep
import Unique
import Var as V
import qualified Data.Maybe as MB
mkIOStr :: (Outputable a) => a -> IO String
mkIOStr obj = runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
let ppr_str = showPpr dflags obj
return ppr_str
mkTargetBindings :: FilePath -> FilePath -> IO [SL.Binding]
mkTargetBindings proj src = do
(sums_gutss, dflags, env) <- mkCompileClosure proj src
let (sums, gutss) = (map fst sums_gutss, map snd sums_gutss)
let mod_lcs = map (\s -> (ms_mod s, ms_location s)) sums
let m_bndss = map mg_binds gutss
let m_tcss = map mg_tcs gutss
let z1 = zip3 mod_lcs m_bndss m_tcss
preps <- mapM (\((m, l), b, t) -> corePrepPgm env m l b t) z1
let z2 = zip (map fst mod_lcs) preps
s_bndss <- mapM (\(m, p) -> coreToStg dflags m p) z2
let sl_bnds = map mkBinding (concat s_bndss)
return sl_bnds
mkCompileClosure :: FilePath -> FilePath ->
IO ([(ModSummary, ModGuts)], DynFlags, HscEnv)
mkCompileClosure proj src = runGhc (Just libdir) $ do
beta_flags <- getSessionDynFlags
let dflags = beta_flags { importPaths = [proj] }
_ <- setSessionDynFlags dflags
env <- getSession
target <- guessTarget src Nothing
_ <- setTargets [target]
_ <- load LoadAllTargets
mod_graph <- getModuleGraph
pmods <- mapM parseModule mod_graph
tmods <- mapM typecheckModule pmods
dmods <- mapM desugarModule tmods
let m_gtss = map coreModule dmods
let zipd = (zip mod_graph m_gtss, dflags, env)
return zipd
mkExpr :: StgExpr -> SL.Expr
mkExpr (StgLit lit) = SL.Atom (SL.LitAtom (mkLit lit))
mkExpr (StgApp occ args) = SL.FunApp (mkVar occ) (map mkAtom args)
mkExpr (StgConApp dc args) = SL.ConApp (mkData dc) (map mkAtom args)
mkExpr (StgOpApp op args _) = SL.PrimApp (mkPrimOp op) (map mkAtom args)
mkExpr (StgTick _ expr) = mkExpr expr
mkExpr (StgLam _ _) = error "mkExpr: StgLam detected"
mkExpr (StgLet bnd expr) = SL.Let (mkBinding bnd) (mkExpr expr)
mkExpr (StgLetNoEscape _ _ bnd expr) = mkExpr (StgLet bnd expr)
mkExpr (StgCase mexpr _ _ bndr _ _ alts) = SL.Case (mkExpr mexpr) (mkVar bndr)
(map mkAlt alts)
mkAtom :: StgArg -> SL.Atom
mkAtom (StgVarArg occ) = SL.VarAtom (mkVar occ)
mkAtom (StgLitArg lit) = SL.LitAtom (mkLit lit)
mkName :: Name -> SL.Name
mkName name = SL.Name occ mdl ns unq
where occ = (occNameString . nameOccName) name
ns = (mkNameSpace . occNameSpace . nameOccName) name
unq = (getKey . nameUnique) name
mdl = case nameModule_maybe name of
Nothing -> Nothing
Just md -> Just ((moduleNameString . moduleName) md)
mkNameSpace :: NameSpace -> SL.NameSpace
mkNameSpace ns | isVarNameSpace ns = SL.VarNSpace
| isTvNameSpace ns = SL.TvNSpace
| isDataConNameSpace ns = SL.DataNSpace
| isTcClsNameSpace ns = SL.TcClsNSpace
| otherwise = error "mkNameSpace: unrecognized"
mkVar :: Var -> SL.Var
mkVar var = SL.Var vname vtype
where vname = (mkName . V.varName) var
vtype = (mkType . varType) var
mkBinding :: StgBinding -> SL.Binding
mkBinding (StgNonRec bnd r) = SL.Binding SL.NonRec [(mkVar bnd, mkRhs r)]
mkBinding (StgRec bnd) = SL.Binding SL.Rec (map (\(b, r) ->
(mkVar b, mkRhs r)) bnd)
mkRhs :: StgRhs -> SL.BindRhs
mkRhs (StgRhsCon _ dc args) = SL.ConForm (mkData dc) (map mkAtom args)
mkRhs (StgRhsClosure _ _ _ _ _ ps e) = SL.FunForm (map mkVar ps) (mkExpr e)
mkLit :: Literal -> SL.Lit
mkLit lit = case lit of
(MachChar chr) -> SL.MachChar chr ((mkType . literalType) lit)
(MachStr bstr) -> SL.MachStr (show bstr) ((mkType . literalType) lit)
(MachInt i) -> SL.MachInt (fromInteger i) ((mkType . literalType) lit)
(MachInt64 i) -> SL.MachInt (fromInteger i) ((mkType . literalType) lit)
(MachWord i) -> SL.MachWord (fromInteger i) ((mkType . literalType) lit)
(MachWord64 i) -> SL.MachWord (fromInteger i) ((mkType . literalType) lit)
(MachFloat rat) -> SL.MachFloat rat ((mkType . literalType) lit)
(MachDouble rat) -> SL.MachDouble rat ((mkType . literalType) lit)
(LitInteger i _) -> SL.MachInt (fromInteger i) ((mkType . literalType) lit)
(MachNullAddr) -> SL.MachNullAddr ((mkType . literalType) lit)
(MachLabel f m _) -> SL.MachLabel (unpackFS f) m ((mkType . literalType) lit)
mkDataName :: DataCon -> SL.Name
mkDataName datacon = (mkName. dataConName) datacon
mkData :: DataCon -> SL.DataCon
mkData datacon = SL.DataCon name ty args
where name = mkDataName datacon
ty = (mkType . dataConRepType) datacon
args = map mkType (dataConOrigArgTys datacon)
mkPrimOp :: StgOp -> SL.PrimFun
mkPrimOp (StgPrimOp op) = SL.PrimFun (SL.Name occ Nothing ns unq) ty
where occname = primOpOcc op
occ = occNameString occname
ns = (mkNameSpace . occNameSpace) occname
unq = primOpTag op
ty = (mkType . primOpType) op
mkPrimOp _ = error "mkPrimOp: got StgPrimCallOp or StgFCallOp"
mkAlt :: StgAlt -> SL.Alt
mkAlt (a, b, _, e) = SL.Alt (mkAltCon a) (map mkVar b) (mkExpr e)
mkAltCon :: AltCon -> SL.AltCon
mkAltCon (DataAlt dc) = SL.DataAlt (mkData dc)
mkAltCon (LitAlt lit) = SL.LitAlt (mkLit lit)
mkAltCon (DEFAULT) = SL.Default
mkType :: Type -> SL.Type
mkType (AppTy t1 t2) = SL.AppTy (mkType t1) (mkType t2)
mkType (TyConApp tc ts) = SL.TyConApp (mkTyCon tc) (map mkType ts)
mkType (ForAllTy b ty) = SL.ForAllTy (mkTyBndr b) (mkType ty)
mkType (LitTy tlit) = SL.LitTy (mkTyLit tlit)
mkType (CastTy ty cor) = SL.CastTy (mkType ty) (mkCoercion cor)
mkType (CoercionTy cor) = SL.CoercionTy (mkCoercion cor)
mkType (TyVarTy v) = SL.TyVarTy (mkName (V.varName v))
(mkType (varType v))
mkTyCon :: TyCon -> SL.TyCon
mkTyCon tc | isFunTyCon tc = SL.FunTyCon name tcbndrs
| isAlgTyCon tc = SL.AlgTyCon name tvnames algrhs
| isFamilyTyCon tc = SL.FamilyTyCon name tvnames
| isPrimTyCon tc = SL.PrimTyCon name tcbndrs
| isTypeSynonymTyCon tc = SL.SynonymTyCon name tvnames
| isPromotedDataCon tc = SL.Promoted name tcbndrs dcon
| otherwise = error "mkTyCon: unrecognized TyCon"
where name = (mkName . tyConName) tc
algrhs = (mkAlgTyConRhs . algTyConRhs) tc
tcbndrs = map mkTyBndr (tyConBinders tc)
tvnames = map (mkName. V.varName) (tyConTyVars tc)
dcon = (mkData . MB.fromJust . isPromotedDataCon_maybe) tc
mkAlgTyConRhs :: AlgTyConRhs -> SL.AlgTyRhs
mkAlgTyConRhs (AbstractTyCon b) = SL.AbstractTyCon b
mkAlgTyConRhs (DataTyCon {data_cons = ds}) = SL.DataTyCon (map mkDataName ds)
mkAlgTyConRhs (TupleTyCon {data_con = d}) = SL.TupleTyCon (mkDataName d)
mkAlgTyConRhs (NewTyCon {data_con = d}) = SL.NewTyCon (mkDataName d)
mkTyBndr :: TyBinder -> SL.TyBinder
mkTyBndr (Anon _) = SL.AnonTyBndr
mkTyBndr (Named v _) = SL.NamedTyBndr (mkName (V.varName v))
mkTyLit :: TyLit -> SL.TyLit
mkTyLit (NumTyLit i) = SL.NumTyLit (fromInteger i)
mkTyLit (StrTyLit fs) = SL.StrTyLit (unpackFS fs)
mkCoercion :: Coercion -> SL.Coercion
mkCoercion coer = SL.Coercion (mkType a) (mkType b)
where (a, b) = (unPair . coercionKind) coer