{-# LANGUAGE CPP #-}

-- | Functions for converting Core things to interface file things.
module ToIface
    ( -- * Binders
      toIfaceTvBndr
    , toIfaceTvBndrs
    , toIfaceIdBndr
    , toIfaceBndr
    , toIfaceForAllBndr
    , toIfaceTyCoVarBinders
    , toIfaceTyVar
      -- * Types
    , toIfaceType, toIfaceTypeX
    , toIfaceKind
    , toIfaceTcArgs
    , toIfaceTyCon
    , toIfaceTyCon_name
    , toIfaceTyLit
      -- * Tidying types
    , tidyToIfaceType
    , tidyToIfaceContext
    , tidyToIfaceTcArgs
      -- * Coercions
    , toIfaceCoercion, toIfaceCoercionX
      -- * Pattern synonyms
    , patSynToIfaceDecl
      -- * Expressions
    , toIfaceExpr
    , toIfaceBang
    , toIfaceSrcBang
    , toIfaceLetBndr
    , toIfaceIdDetails
    , toIfaceIdInfo
    , toIfUnfolding
    , toIfaceOneShot
    , toIfaceTickish
    , toIfaceBind
    , toIfaceAlt
    , toIfaceCon
    , toIfaceApp
    , toIfaceVar
    ) where

#include "HsVersions.h"

import GhcPrelude

import IfaceSyn
import DataCon
import Id
import IdInfo
import CoreSyn
import TyCon hiding ( pprPromotionQuote )
import CoAxiom
import TysPrim ( eqPrimTyCon, eqReprPrimTyCon )
import TysWiredIn ( heqTyCon )
import MkId ( noinlineIdName )
import PrelNames
import Name
import BasicTypes
import Type
import PatSyn
import Outputable
import FastString
import Util
import Var
import VarEnv
import VarSet
import TyCoRep
import Demand ( isTopSig )

import Data.Maybe ( catMaybes )

----------------
toIfaceTvBndr :: TyVar -> IfaceTvBndr
toIfaceTvBndr = toIfaceTvBndrX emptyVarSet

toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr
toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar)
                          , toIfaceTypeX fr (tyVarKind tyvar)
                          )

toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr]
toIfaceTvBndrs = map toIfaceTvBndr

toIfaceIdBndr :: Id -> IfaceIdBndr
toIfaceIdBndr = toIfaceIdBndrX emptyVarSet

toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr
toIfaceIdBndrX fr covar = ( occNameFS (getOccName covar)
                          , toIfaceTypeX fr (varType covar)
                          )

toIfaceBndr :: Var -> IfaceBndr
toIfaceBndr var
  | isId var  = IfaceIdBndr (toIfaceIdBndr var)
  | otherwise = IfaceTvBndr (toIfaceTvBndr var)

toIfaceBndrX :: VarSet -> Var -> IfaceBndr
toIfaceBndrX fr var
  | isId var  = IfaceIdBndr (toIfaceIdBndrX fr var)
  | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var)

toIfaceTyCoVarBinder :: VarBndr Var vis -> VarBndr IfaceBndr vis
toIfaceTyCoVarBinder (Bndr tv vis) = Bndr (toIfaceBndr tv) vis

toIfaceTyCoVarBinders :: [VarBndr Var vis] -> [VarBndr IfaceBndr vis]
toIfaceTyCoVarBinders = map toIfaceTyCoVarBinder

{-
************************************************************************
*                                                                      *
        Conversion from Type to IfaceType
*                                                                      *
************************************************************************
-}

toIfaceKind :: Type -> IfaceType
toIfaceKind = toIfaceType

---------------------
toIfaceType :: Type -> IfaceType
toIfaceType = toIfaceTypeX emptyVarSet

toIfaceTypeX :: VarSet -> Type -> IfaceType
-- (toIfaceTypeX free ty)
--    translates the tyvars in 'free' as IfaceFreeTyVars
--
-- Synonyms are retained in the interface type
toIfaceTypeX fr (TyVarTy tv)   -- See Note [TcTyVars in IfaceType] in IfaceType
  | tv `elemVarSet` fr         = IfaceFreeTyVar tv
  | otherwise                  = IfaceTyVar (toIfaceTyVar tv)
toIfaceTypeX fr ty@(AppTy {})  =
  -- Flatten as many argument AppTys as possible, then turn them into an
  -- IfaceAppArgs list.
  -- See Note [Suppressing invisible arguments] in IfaceType.
  let (head, args) = splitAppTys ty
  in IfaceAppTy (toIfaceTypeX fr head) (toIfaceAppTyArgsX fr head args)
toIfaceTypeX _  (LitTy n)      = IfaceLitTy (toIfaceTyLit n)
toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b)
                                               (toIfaceTypeX (fr `delVarSet` binderVar b) t)
toIfaceTypeX fr (FunTy { ft_arg = t1, ft_res = t2, ft_af = af })
  = IfaceFunTy af (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)
toIfaceTypeX fr (CastTy ty co)  = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCoercionX fr co)
toIfaceTypeX fr (CoercionTy co) = IfaceCoercionTy (toIfaceCoercionX fr co)

toIfaceTypeX fr (TyConApp tc tys)
    -- tuples
  | Just sort <- tyConTuple_maybe tc
  , n_tys == arity
  = IfaceTupleTy sort NotPromoted (toIfaceTcArgsX fr tc tys)

  | Just dc <- isPromotedDataCon_maybe tc
  , isTupleDataCon dc
  , n_tys == 2*arity
  = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys))

  | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ]
  , (k1:k2:_) <- tys
  = let info = IfaceTyConInfo NotPromoted sort
        sort | k1 `eqType` k2 = IfaceEqualityTyCon
             | otherwise      = IfaceNormalTyCon
    in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys)

    -- other applications
  | otherwise
  = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgsX fr tc tys)
  where
    arity = tyConArity tc
    n_tys = length tys

toIfaceTyVar :: TyVar -> FastString
toIfaceTyVar = occNameFS . getOccName

toIfaceCoVar :: CoVar -> FastString
toIfaceCoVar = occNameFS . getOccName

toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr
toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet

toIfaceForAllBndrX :: VarSet -> TyCoVarBinder -> IfaceForAllBndr
toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis

----------------
toIfaceTyCon :: TyCon -> IfaceTyCon
toIfaceTyCon tc
  = IfaceTyCon tc_name info
  where
    tc_name = tyConName tc
    info    = IfaceTyConInfo promoted sort
    promoted | isPromotedDataCon tc = IsPromoted
             | otherwise            = NotPromoted

    tupleSort :: TyCon -> Maybe IfaceTyConSort
    tupleSort tc' =
        case tyConTuple_maybe tc' of
          Just UnboxedTuple -> let arity = tyConArity tc' `div` 2
                               in Just $ IfaceTupleTyCon arity UnboxedTuple
          Just sort         -> let arity = tyConArity tc'
                               in Just $ IfaceTupleTyCon arity sort
          Nothing           -> Nothing

    sort
      | Just tsort <- tupleSort tc           = tsort

      | Just dcon <- isPromotedDataCon_maybe tc
      , let tc' = dataConTyCon dcon
      , Just tsort <- tupleSort tc'          = tsort

      | isUnboxedSumTyCon tc
      , Just cons <- isDataSumTyCon_maybe tc = IfaceSumTyCon (length cons)

      | otherwise                            = IfaceNormalTyCon

toIfaceTyCon_name :: Name -> IfaceTyCon
toIfaceTyCon_name n = IfaceTyCon n info
  where info = IfaceTyConInfo NotPromoted IfaceNormalTyCon
  -- Used for the "rough-match" tycon stuff,
  -- where pretty-printing is not an issue

toIfaceTyLit :: TyLit -> IfaceTyLit
toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x
toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x

----------------
toIfaceCoercion :: Coercion -> IfaceCoercion
toIfaceCoercion = toIfaceCoercionX emptyVarSet

toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion
-- (toIfaceCoercionX free ty)
--    translates the tyvars in 'free' as IfaceFreeTyVars
toIfaceCoercionX fr co
  = go co
  where
    go_mco MRefl     = IfaceMRefl
    go_mco (MCo co)  = IfaceMCo $ go co

    go (Refl ty)            = IfaceReflCo (toIfaceTypeX fr ty)
    go (GRefl r ty mco)     = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco)
    go (CoVarCo cv)
      -- See [TcTyVars in IfaceType] in IfaceType
      | cv `elemVarSet` fr  = IfaceFreeCoVar cv
      | otherwise           = IfaceCoVarCo (toIfaceCoVar cv)
    go (HoleCo h)           = IfaceHoleCo  (coHoleCoVar h)

    go (AppCo co1 co2)      = IfaceAppCo  (go co1) (go co2)
    go (SymCo co)           = IfaceSymCo (go co)
    go (TransCo co1 co2)    = IfaceTransCo (go co1) (go co2)
    go (NthCo _r d co)      = IfaceNthCo d (go co)
    go (LRCo lr co)         = IfaceLRCo lr (go co)
    go (InstCo co arg)      = IfaceInstCo (go co) (go arg)
    go (KindCo c)           = IfaceKindCo (go c)
    go (SubCo co)           = IfaceSubCo (go co)
    go (AxiomRuleCo co cs)  = IfaceAxiomRuleCo (coaxrName co) (map go cs)
    go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs)
    go (UnivCo p r t1 t2)   = IfaceUnivCo (go_prov p) r
                                          (toIfaceTypeX fr t1)
                                          (toIfaceTypeX fr t2)
    go (TyConAppCo r tc cos)
      | tc `hasKey` funTyConKey
      , [_,_,_,_] <- cos         = pprPanic "toIfaceCoercion" (ppr co)
      | otherwise                = IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos)
    go (FunCo r co1 co2)   = IfaceFunCo r (go co1) (go co2)

    go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv)
                                          (toIfaceCoercionX fr' k)
                                          (toIfaceCoercionX fr' co)
                          where
                            fr' = fr `delVarSet` tv

    go_prov :: UnivCoProvenance -> IfaceUnivCoProv
    go_prov UnsafeCoerceProv    = IfaceUnsafeCoerceProv
    go_prov (PhantomProv co)    = IfacePhantomProv (go co)
    go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)
    go_prov (PluginProv str)    = IfacePluginProv str

toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs
toIfaceTcArgs = toIfaceTcArgsX emptyVarSet

toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceAppArgs
toIfaceTcArgsX fr tc ty_args = toIfaceAppArgsX fr (tyConKind tc) ty_args

toIfaceAppTyArgsX :: VarSet -> Type -> [Type] -> IfaceAppArgs
toIfaceAppTyArgsX fr ty ty_args = toIfaceAppArgsX fr (typeKind ty) ty_args

toIfaceAppArgsX :: VarSet -> Kind -> [Type] -> IfaceAppArgs
-- See Note [Suppressing invisible arguments] in IfaceType
-- We produce a result list of args describing visibility
-- The awkward case is
--    T :: forall k. * -> k
-- And consider
--    T (forall j. blah) * blib
-- Is 'blib' visible?  It depends on the visibility flag on j,
-- so we have to substitute for k.  Annoying!
toIfaceAppArgsX fr kind ty_args
  = go (mkEmptyTCvSubst in_scope) kind ty_args
  where
    in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)

    go _   _                   []     = IA_Nil
    go env ty                  ts
      | Just ty' <- coreView ty
      = go env ty' ts
    go env (ForAllTy (Bndr tv vis) res) (t:ts)
      = IA_Arg t' vis ts'
      where
        t'  = toIfaceTypeX fr t
        ts' = go (extendTCvSubst env tv t) res ts

    go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps
      = IA_Arg (toIfaceTypeX fr t) Required (go env res ts)

    go env ty ts@(t1:ts1)
      | not (isEmptyTCvSubst env)
      = go (zapTCvSubst env) (substTy env ty) ts
        -- See Note [Care with kind instantiation] in Type.hs

      | otherwise
      = -- There's a kind error in the type we are trying to print
        -- e.g. kind = k, ty_args = [Int]
        -- This is probably a compiler bug, so we print a trace and
        -- carry on as if it were FunTy.  Without the test for
        -- isEmptyTCvSubst we'd get an infinite loop (Trac #15473)
        WARN( True, ppr kind $$ ppr ty_args )
        IA_Arg (toIfaceTypeX fr t1) Required (go env ty ts1)

tidyToIfaceType :: TidyEnv -> Type -> IfaceType
tidyToIfaceType env ty = toIfaceType (tidyType env ty)

tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs
tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys)

tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext
tidyToIfaceContext env theta = map (tidyToIfaceType env) theta

{-
************************************************************************
*                                                                      *
        Conversion of pattern synonyms
*                                                                      *
************************************************************************
-}

patSynToIfaceDecl :: PatSyn -> IfaceDecl
patSynToIfaceDecl ps
  = IfacePatSyn { ifName          = getName $ ps
                , ifPatMatcher    = to_if_pr (patSynMatcher ps)
                , ifPatBuilder    = fmap to_if_pr (patSynBuilder ps)
                , ifPatIsInfix    = patSynIsInfix ps
                , ifPatUnivBndrs  = map toIfaceForAllBndr univ_bndrs'
                , ifPatExBndrs    = map toIfaceForAllBndr ex_bndrs'
                , ifPatProvCtxt   = tidyToIfaceContext env2 prov_theta
                , ifPatReqCtxt    = tidyToIfaceContext env2 req_theta
                , ifPatArgs       = map (tidyToIfaceType env2) args
                , ifPatTy         = tidyToIfaceType env2 rhs_ty
                , ifFieldLabels   = (patSynFieldLabels ps)
                }
  where
    (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps
    univ_bndrs = patSynUnivTyVarBinders ps
    ex_bndrs   = patSynExTyVarBinders ps
    (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs
    (env2, ex_bndrs')   = tidyTyCoVarBinders env1 ex_bndrs
    to_if_pr (id, needs_dummy) = (idName id, needs_dummy)

{-
************************************************************************
*                                                                      *
        Conversion of other things
*                                                                      *
************************************************************************
-}

toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang
toIfaceBang _    HsLazy              = IfNoBang
toIfaceBang _   (HsUnpack Nothing)   = IfUnpack
toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))
toIfaceBang _   HsStrict             = IfStrict

toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang
toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang

toIfaceLetBndr :: Id -> IfaceLetBndr
toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
                               (toIfaceType (idType id))
                               (toIfaceIdInfo (idInfo id))
                               (toIfaceJoinInfo (isJoinId_maybe id))
  -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr
  -- has left on the Id.  See Note [IdInfo on nested let-bindings] in IfaceSyn

toIfaceIdDetails :: IdDetails -> IfaceIdDetails
toIfaceIdDetails VanillaId                      = IfVanillaId
toIfaceIdDetails (DFunId {})                    = IfDFunId
toIfaceIdDetails (RecSelId { sel_naughty = n
                           , sel_tycon = tc })  =
  let iface = case tc of
                RecSelData ty_con -> Left (toIfaceTyCon ty_con)
                RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn)
  in IfRecSelId iface n

  -- The remaining cases are all "implicit Ids" which don't
  -- appear in interface files at all
toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
                         IfVanillaId   -- Unexpected; the other

toIfaceIdInfo :: IdInfo -> IfaceIdInfo
toIfaceIdInfo id_info
  = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
                    inline_hsinfo,  unfold_hsinfo, levity_hsinfo] of
       []    -> NoInfo
       infos -> HasInfo infos
               -- NB: strictness and arity must appear in the list before unfolding
               -- See TcIface.tcUnfolding
  where
    ------------  Arity  --------------
    arity_info = arityInfo id_info
    arity_hsinfo | arity_info == 0 = Nothing
                 | otherwise       = Just (HsArity arity_info)

    ------------ Caf Info --------------
    caf_info   = cafInfo id_info
    caf_hsinfo = case caf_info of
                   NoCafRefs -> Just HsNoCafRefs
                   _other    -> Nothing

    ------------  Strictness  --------------
        -- No point in explicitly exporting TopSig
    sig_info = strictnessInfo id_info
    strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info)
                  | otherwise               = Nothing

    ------------  Unfolding  --------------
    unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info)
    loop_breaker  = isStrongLoopBreaker (occInfo id_info)

    ------------  Inline prag  --------------
    inline_prag = inlinePragInfo id_info
    inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
                  | otherwise = Just (HsInline inline_prag)

    ------------  Levity polymorphism  ----------
    levity_hsinfo | isNeverLevPolyIdInfo id_info = Just HsLevity
                  | otherwise                    = Nothing

toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo
toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar
toIfaceJoinInfo Nothing   = IfaceNotJoinPoint

--------------------------
toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs
                                , uf_src = src
                                , uf_guidance = guidance })
  = Just $ HsUnfold lb $
    case src of
        InlineStable
          -> case guidance of
               UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok =  boring_ok }
                      -> IfInlineRule arity unsat_ok boring_ok if_rhs
               _other -> IfCoreUnfold True if_rhs
        InlineCompulsory -> IfCompulsory if_rhs
        InlineRhs        -> IfCoreUnfold False if_rhs
        -- Yes, even if guidance is UnfNever, expose the unfolding
        -- If we didn't want to expose the unfolding, TidyPgm would
        -- have stuck in NoUnfolding.  For supercompilation we want
        -- to see that unfolding!
  where
    if_rhs = toIfaceExpr rhs

toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args })
  = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args)))
      -- No need to serialise the data constructor;
      -- we can recover it from the type of the dfun

toIfUnfolding _ (OtherCon {}) = Nothing
  -- The binding site of an Id doesn't have OtherCon, except perhaps
  -- where we have called zapUnfolding; and that evald'ness info is
  -- not needed by importing modules

toIfUnfolding _ BootUnfolding = Nothing
  -- Can't happen; we only have BootUnfolding for imported binders

toIfUnfolding _ NoUnfolding = Nothing

{-
************************************************************************
*                                                                      *
        Conversion of expressions
*                                                                      *
************************************************************************
-}

toIfaceExpr :: CoreExpr -> IfaceExpr
toIfaceExpr (Var v)         = toIfaceVar v
toIfaceExpr (Lit l)         = IfaceLit l
toIfaceExpr (Type ty)       = IfaceType (toIfaceType ty)
toIfaceExpr (Coercion co)   = IfaceCo   (toIfaceCoercion co)
toIfaceExpr (Lam x b)       = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b)
toIfaceExpr (App f a)       = toIfaceApp f [a]
toIfaceExpr (Case s x ty as)
  | null as                 = IfaceECase (toIfaceExpr s) (toIfaceType ty)
  | otherwise               = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as)
toIfaceExpr (Let b e)       = IfaceLet (toIfaceBind b) (toIfaceExpr e)
toIfaceExpr (Cast e co)     = IfaceCast (toIfaceExpr e) (toIfaceCoercion co)
toIfaceExpr (Tick t e)
  | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e)
  | otherwise                   = toIfaceExpr e

toIfaceOneShot :: Id -> IfaceOneShot
toIfaceOneShot id | isId id
                  , OneShotLam <- oneShotInfo (idInfo id)
                  = IfaceOneShot
                  | otherwise
                  = IfaceNoOneShot

---------------------
toIfaceTickish :: Tickish Id -> Maybe IfaceTickish
toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push)
toIfaceTickish (HpcTick modl ix)       = Just (IfaceHpcTick modl ix)
toIfaceTickish (SourceNote src names)  = Just (IfaceSource src names)
toIfaceTickish (Breakpoint {})         = Nothing
   -- Ignore breakpoints, since they are relevant only to GHCi, and
   -- should not be serialised (Trac #8333)

---------------------
toIfaceBind :: Bind Id -> IfaceBinding
toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
toIfaceBind (Rec prs)    = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]

---------------------
toIfaceAlt :: (AltCon, [Var], CoreExpr)
           -> (IfaceConAlt, [FastString], IfaceExpr)
toIfaceAlt (c,bs,r) = (toIfaceCon c, map getOccFS bs, toIfaceExpr r)

---------------------
toIfaceCon :: AltCon -> IfaceConAlt
toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc)
toIfaceCon (LitAlt l)   = IfaceLitAlt l
toIfaceCon DEFAULT      = IfaceDefault

---------------------
toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
toIfaceApp (App f a) as = toIfaceApp f (a:as)
toIfaceApp (Var v) as
  = case isDataConWorkId_maybe v of
        -- We convert the *worker* for tuples into IfaceTuples
        Just dc |  saturated
                ,  Just tup_sort <- tyConTuple_maybe tc
                -> IfaceTuple tup_sort tup_args
          where
            val_args  = dropWhile isTypeArg as
            saturated = val_args `lengthIs` idArity v
            tup_args  = map toIfaceExpr val_args
            tc        = dataConTyCon dc

        _ -> mkIfaceApps (toIfaceVar v) as

toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as

mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as

---------------------
toIfaceVar :: Id -> IfaceExpr
toIfaceVar v
    | isBootUnfolding (idUnfolding v)
    = -- See Note [Inlining and hs-boot files]
      IfaceApp (IfaceApp (IfaceExt noinlineIdName)
                         (IfaceType (toIfaceType (idType v))))
               (IfaceExt name) -- don't use mkIfaceApps, or infinite loop

    | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
                                      -- Foreign calls have special syntax

    | isExternalName name             = IfaceExt name
    | otherwise                       = IfaceLcl (getOccFS name)
  where name = idName v

{- Note [Inlining and hs-boot files]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this example (Trac #10083, #12789):

    ---------- RSR.hs-boot ------------
    module RSR where
      data RSR
      eqRSR :: RSR -> RSR -> Bool

    ---------- SR.hs ------------
    module SR where
      import {-# SOURCE #-} RSR
      data SR = MkSR RSR
      eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2

    ---------- RSR.hs ------------
    module RSR where
      import SR
      data RSR = MkRSR SR -- deriving( Eq )
      eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2)
      foo x y = not (eqRSR x y)

When compiling RSR we get this code

    RSR.eqRSR :: RSR -> RSR -> Bool
    RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) ->
                case ds1 of _ { RSR.MkRSR s1 ->
                case ds2 of _ { RSR.MkRSR s2 ->
                SR.eqSR s1 s2 }}

    RSR.foo :: RSR -> RSR -> Bool
    RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y)

Now, when optimising foo:
    Inline eqRSR (small, non-rec)
    Inline eqSR  (small, non-rec)
but the result of inlining eqSR from SR is another call to eqRSR, so
everything repeats.  Neither eqSR nor eqRSR are (apparently) loop
breakers.

Solution: in the unfolding of eqSR in SR.hi, replace `eqRSR` in SR
with `noinline eqRSR`, so that eqRSR doesn't get inlined.  This means
that when GHC inlines `eqSR`, it will not also inline `eqRSR`, exactly
as would have been the case if `foo` had been defined in SR.hs (and
marked as a loop-breaker).

But how do we arrange for this to happen?  There are two ingredients:

    1. When we serialize out unfoldings to IfaceExprs (toIfaceVar),
    for every variable reference we see if we are referring to an
    'Id' that came from an hs-boot file.  If so, we add a `noinline`
    to the reference.

    2. But how do we know if a reference came from an hs-boot file
    or not?  We could record this directly in the 'IdInfo', but
    actually we deduce this by looking at the unfolding: 'Id's
    that come from boot files are given a special unfolding
    (upon typechecking) 'BootUnfolding' which say that there is
    no unfolding, and the reason is because the 'Id' came from
    a boot file.

Here is a solution that doesn't work: when compiling RSR,
add a NOINLINE pragma to every function exported by the boot-file
for RSR (if it exists).  Doing so makes the bootstrapped GHC itself
slower by 8% overall (on Trac #9872a-d, and T1969: the reason
is that these NOINLINE'd functions now can't be profitably inlined
outside of the hs-boot loop.

-}


-- ----------------------------------------------------------------------------
-- | This module supplies bindings to generate Llvm IR from Haskell
-- (<http://www.llvm.org/docs/LangRef.html>).
--
-- Note: this module is developed in a demand driven way. It is no complete
-- LLVM binding library in Haskell, but enough to generate code for GHC.
--
-- This code is derived from code taken from the Essential Haskell Compiler
-- (EHC) project (<http://www.cs.uu.nl/wiki/Ehc/WebHome>).
--

module Llvm (

        -- * Modules, Functions and Blocks
        LlvmModule(..),

        LlvmFunction(..), LlvmFunctionDecl(..),
        LlvmFunctions, LlvmFunctionDecls,
        LlvmStatement(..), LlvmExpression(..),
        LlvmBlocks, LlvmBlock(..), LlvmBlockId,
        LlvmParamAttr(..), LlvmParameter,

        -- * Atomic operations
        LlvmAtomicOp(..),

        -- * Fence synchronization
        LlvmSyncOrdering(..),

        -- * Call Handling
        LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..),
        LlvmLinkageType(..), LlvmFuncAttr(..),

        -- * Operations and Comparisons
        LlvmCmpOp(..), LlvmMachOp(..), LlvmCastOp(..),

        -- * Variables and Type System
        LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..),
        LlvmAlias, LMGlobal(..), LMString, LMSection, LMAlign,
        LMConst(..),

        -- ** Some basic types
        i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr,

        -- ** Metadata types
        MetaExpr(..), MetaAnnot(..), MetaDecl(..), MetaId(..),

        -- ** Operations on the type system.
        isGlobal, getLitType, getVarType,
        getLink, getStatType, pVarLift, pVarLower,
        pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits,

        -- * Pretty Printing
        ppLit, ppName, ppPlainName,
        ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
        ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,
        ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,

    ) where

import Llvm.AbsSyn
import Llvm.MetaData
import Llvm.PpLlvm
import Llvm.Types


{-# LANGUAGE CPP, TypeFamilies, ViewPatterns #-}

-- -----------------------------------------------------------------------------
-- | This is the top-level module in the LLVM code generator.
--
module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where

#include "HsVersions.h"

import GhcPrelude

import Llvm
import LlvmCodeGen.Base
import LlvmCodeGen.CodeGen
import LlvmCodeGen.Data
import LlvmCodeGen.Ppr
import LlvmCodeGen.Regs
import LlvmMangler

import BlockId
import CgUtils ( fixStgRegisters )
import Cmm
import CmmUtils
import Hoopl.Block
import Hoopl.Collections
import PprCmm

import BufWrite
import DynFlags
import ErrUtils
import FastString
import Outputable
import UniqSupply
import SysTools ( figureLlvmVersion )
import qualified Stream

import Control.Monad ( when )
import Data.Maybe ( fromMaybe, catMaybes )
import System.IO

-- -----------------------------------------------------------------------------
-- | Top-level of the LLVM Code generator
--
llvmCodeGen :: DynFlags -> Handle -> UniqSupply
               -> Stream.Stream IO RawCmmGroup ()
               -> IO ()
llvmCodeGen dflags h us cmm_stream
  = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do
       bufh <- newBufHandle h

       -- Pass header
       showPass dflags "LLVM CodeGen"

       -- get llvm version, cache for later use
       ver <- (fromMaybe supportedLlvmVersion) `fmap` figureLlvmVersion dflags

       -- warn if unsupported
       debugTraceMsg dflags 2
            (text "Using LLVM version:" <+> text (show ver))
       let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
       when (ver /= supportedLlvmVersion && doWarn) $
           putMsg dflags (text "You are using an unsupported version of LLVM!"
                            $+$ text ("Currently only " ++
                                      llvmVersionStr supportedLlvmVersion ++
                                      " is supported.")
                            $+$ text "We will try though...")

       -- run code generation
       runLlvm dflags ver bufh us $
         llvmCodeGen' (liftStream cmm_stream)

       bFlush bufh

llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM ()
llvmCodeGen' cmm_stream
  = do  -- Preamble
        renderLlvm header
        ghcInternalFunctions
        cmmMetaLlvmPrelude

        -- Procedures
        let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream
        _ <- Stream.collect llvmStream

        -- Declare aliases for forward references
        renderLlvm . pprLlvmData =<< generateExternDecls

        -- Postamble
        cmmUsedLlvmGens
  where
    header :: SDoc
    header = sdocWithDynFlags $ \dflags ->
      let target = LLVM_TARGET
          layout = case lookup target (llvmTargets dflags) of
            Just (LlvmTarget dl _ _) -> dl
            Nothing -> error $ "Failed to lookup the datalayout for " ++ target ++ "; available targets: " ++ show (map fst $ llvmTargets dflags)
      in     text ("target datalayout = \"" ++ layout ++ "\"")
         $+$ text ("target triple = \"" ++ target ++ "\"")

llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
llvmGroupLlvmGens cmm = do

        -- Insert functions into map, collect data
        let split (CmmData s d' )     = return $ Just (s, d')
            split (CmmProc h l live g) = do
              -- Set function type
              let l' = case mapLookup (g_entry g) h of
                         Nothing                   -> l
                         Just (Statics info_lbl _) -> info_lbl
              lml <- strCLabel_llvm l'
              funInsert lml =<< llvmFunTy live
              return Nothing
        cdata <- fmap catMaybes $ mapM split cmm

        {-# SCC "llvm_datas_gen" #-}
          cmmDataLlvmGens cdata
        {-# SCC "llvm_procs_gen" #-}
          mapM_ cmmLlvmGen cmm

-- -----------------------------------------------------------------------------
-- | Do LLVM code generation on all these Cmms data sections.
--
cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM ()

cmmDataLlvmGens statics
  = do lmdatas <- mapM genLlvmData statics

       let (concat -> gs, tss) = unzip lmdatas

       let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)
                        = funInsert l ty
           regGlobal _  = pure ()
       mapM_ regGlobal gs
       gss' <- mapM aliasify $ gs

       renderLlvm $ pprLlvmData (concat gss', concat tss)

-- | LLVM can't handle entry blocks which loop back to themselves (could be
-- seen as an LLVM bug) so we rearrange the code to keep the original entry
-- label which branches to a newly generated second label that branches back
-- to itself. See: Trac #11649
fixBottom :: RawCmmDecl -> LlvmM RawCmmDecl
fixBottom cp@(CmmProc hdr entry_lbl live g) =
    maybe (pure cp) fix_block $ mapLookup (g_entry g) blk_map
  where
    blk_map = toBlockMap g

    fix_block :: CmmBlock -> LlvmM RawCmmDecl
    fix_block blk
        | (CmmEntry e_lbl tickscp, middle, CmmBranch b_lbl) <- blockSplit blk
        , isEmptyBlock middle
        , e_lbl == b_lbl = do
            new_lbl <- mkBlockId <$> getUniqueM

            let fst_blk =
                    BlockCC (CmmEntry e_lbl tickscp) BNil (CmmBranch new_lbl)
                snd_blk =
                    BlockCC (CmmEntry new_lbl tickscp) BNil (CmmBranch new_lbl)

            pure . CmmProc hdr entry_lbl live . ofBlockMap (g_entry g)
                $ mapFromList [(e_lbl, fst_blk), (new_lbl, snd_blk)]

    fix_block _ = pure cp

fixBottom rcd = pure rcd

-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
cmmLlvmGen ::RawCmmDecl -> LlvmM ()
cmmLlvmGen cmm@CmmProc{} = do

    -- rewrite assignments to global regs
    dflags <- getDynFlag id
    fixed_cmm <- fixBottom $
                    {-# SCC "llvm_fix_regs" #-}
                    fixStgRegisters dflags cmm

    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])

    -- generate llvm code from cmm
    llvmBC <- withClearVars $ genLlvmProc fixed_cmm

    -- pretty print
    (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC

    -- Output, note down used variables
    renderLlvm (vcat docs)
    mapM_ markUsedVar $ concat ivars

cmmLlvmGen _ = return ()

-- -----------------------------------------------------------------------------
-- | Generate meta data nodes
--

cmmMetaLlvmPrelude :: LlvmM ()
cmmMetaLlvmPrelude = do
  metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do
    -- Generate / lookup meta data IDs
    tbaaId <- getMetaUniqueId
    setUniqMeta uniq tbaaId
    parentId <- maybe (return Nothing) getUniqMeta parent
    -- Build definition
    return $ MetaUnnamed tbaaId $ MetaStruct $
          case parentId of
              Just p  -> [ MetaStr name, MetaNode p ]
              -- As of LLVM 4.0, a node without parents should be rendered as
              -- just a name on its own. Previously `null` was accepted as the
              -- name.
              Nothing -> [ MetaStr name ]
  renderLlvm $ ppLlvmMetas metas

-- -----------------------------------------------------------------------------
-- | Marks variables as used where necessary
--

cmmUsedLlvmGens :: LlvmM ()
cmmUsedLlvmGens = do

  -- LLVM would discard variables that are internal and not obviously
  -- used if we didn't provide these hints. This will generate a
  -- definition of the form
  --
  --   @llvm.used = appending global [42 x i8*] [i8* bitcast <var> to i8*, ...]
  --
  -- Which is the LLVM way of protecting them against getting removed.
  ivars <- getUsedVars
  let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
      ty     = (LMArray (length ivars) i8Ptr)
      usedArray = LMStaticArray (map cast ivars) ty
      sectName  = Just $ fsLit "llvm.metadata"
      lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant
      lmUsed    = LMGlobal lmUsedVar (Just usedArray)
  if null ivars
     then return ()
     else renderLlvm $ pprLlvmData ([lmUsed], [])


-- -----------------------------------------------------------------------------
-- | GHC LLVM Mangler
--
-- This script processes the assembly produced by LLVM, rewriting all symbols
-- of type @function to @object. This keeps them from going through the PLT,
-- which would be bad due to tables-next-to-code. On x86_64,
-- it also rewrites AVX instructions that require alignment to their
-- unaligned counterparts, since the stack is only 16-byte aligned but these
-- instructions require 32-byte alignment.
--

module LlvmMangler ( llvmFixupAsm ) where

import GhcPrelude

import DynFlags ( DynFlags, targetPlatform )
import Platform ( platformArch, Arch(..) )
import ErrUtils ( withTiming )
import Outputable ( text )

import Control.Exception
import qualified Data.ByteString.Char8 as B
import System.IO

-- | Read in assembly file and process
llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()
llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-}
    withTiming (pure dflags) (text "LLVM Mangler") id $
    withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do
        go r w
        hClose r
        hClose w
        return ()
  where
    go :: Handle -> Handle -> IO ()
    go r w = do
      e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString)
      let writeline a = B.hPutStrLn w (rewriteLine dflags rewrites a) >> go r w
      case e_l of
        Right l -> writeline l
        Left _  -> return ()

-- | These are the rewrites that the mangler will perform
rewrites :: [Rewrite]
rewrites = [rewriteSymType, rewriteAVX]

type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString

-- | Rewrite a line of assembly source with the given rewrites,
-- taking the first rewrite that applies.
rewriteLine :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString
rewriteLine dflags rewrites l
  -- We disable .subsections_via_symbols on darwin and ios, as the llvm code
  -- gen uses prefix data for the info table.  This however does not prevent
  -- llvm from generating .subsections_via_symbols, which in turn with
  -- -dead_strip, strips the info tables, and therefore breaks ghc.
  | isSubsectionsViaSymbols l =
    (B.pack "## no .subsection_via_symbols for ghc. We need our info tables!")
  | otherwise =
    case firstJust $ map (\rewrite -> rewrite dflags rest) rewrites of
      Nothing        -> l
      Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten]
  where
    isSubsectionsViaSymbols = B.isPrefixOf (B.pack ".subsections_via_symbols")

    (symbol, rest) = splitLine l

    firstJust :: [Maybe a] -> Maybe a
    firstJust (Just x:_) = Just x
    firstJust []         = Nothing
    firstJust (_:rest)   = firstJust rest

-- | This rewrites @.type@ annotations of function symbols to @%object@.
-- This is done as the linker can relocate @%functions@ through the
-- Procedure Linking Table (PLT). This is bad since we expect that the
-- info table will appear directly before the symbol's location. In the
-- case that the PLT is used, this will be not an info table but instead
-- some random PLT garbage.
rewriteSymType :: Rewrite
rewriteSymType _ l
  | isType l  = Just $ rewrite '@' $ rewrite '%' l
  | otherwise = Nothing
  where
    isType = B.isPrefixOf (B.pack ".type")

    rewrite :: Char -> B.ByteString -> B.ByteString
    rewrite prefix = replaceOnce funcType objType
      where
        funcType = prefix `B.cons` B.pack "function"
        objType  = prefix `B.cons` B.pack "object"

-- | This rewrites aligned AVX instructions to their unaligned counterparts on
-- x86-64. This is necessary because the stack is not adequately aligned for
-- aligned AVX spills, so LLVM would emit code that adjusts the stack pointer
-- and disable tail call optimization. Both would be catastrophic here so GHC
-- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then
-- rewrites the instructions in the mangler.
rewriteAVX :: Rewrite
rewriteAVX dflags s
  | not isX86_64 = Nothing
  | isVmovdqa s  = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s
  | isVmovap s   = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s
  | otherwise    = Nothing
  where
    isX86_64 = platformArch (targetPlatform dflags) == ArchX86_64
    isVmovdqa = B.isPrefixOf (B.pack "vmovdqa")
    isVmovap = B.isPrefixOf (B.pack "vmovap")

-- | @replaceOnce match replace bs@ replaces the first occurrence of the
-- substring @match@ in @bs@ with @replace@.
replaceOnce :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
replaceOnce matchBS replaceOnceBS = loop
  where
    loop :: B.ByteString -> B.ByteString
    loop cts =
        case B.breakSubstring matchBS cts of
          (hd,tl) | B.null tl -> hd
                  | otherwise -> hd `B.append` replaceOnceBS `B.append`
                                 B.drop (B.length matchBS) tl

-- | This function splits a line of assembly code into the label and the
-- rest of the code.
splitLine :: B.ByteString -> (B.ByteString, B.ByteString)
splitLine l = (symbol, B.dropWhile isSpace rest)
  where
    isSpace ' ' = True
    isSpace '\t' = True
    isSpace _ = False
    (symbol, rest) = B.span (not . isSpace) l


--------------------------------------------------------------------------------
-- | The LLVM abstract syntax.
--

module Llvm.AbsSyn where

import GhcPrelude

import Llvm.MetaData
import Llvm.Types

import Unique

-- | Block labels
type LlvmBlockId = Unique

-- | A block of LLVM code.
data LlvmBlock = LlvmBlock {
    -- | The code label for this block
    blockLabel :: LlvmBlockId,

    -- | A list of LlvmStatement's representing the code for this block.
    -- This list must end with a control flow statement.
    blockStmts :: [LlvmStatement]
  }

type LlvmBlocks = [LlvmBlock]

-- | An LLVM Module. This is a top level container in LLVM.
data LlvmModule = LlvmModule  {
    -- | Comments to include at the start of the module.
    modComments  :: [LMString],

    -- | LLVM Alias type definitions.
    modAliases   :: [LlvmAlias],

    -- | LLVM meta data.
    modMeta      :: [MetaDecl],

    -- | Global variables to include in the module.
    modGlobals   :: [LMGlobal],

    -- | LLVM Functions used in this module but defined in other modules.
    modFwdDecls  :: LlvmFunctionDecls,

    -- | LLVM Functions defined in this module.
    modFuncs     :: LlvmFunctions
  }

-- | An LLVM Function
data LlvmFunction = LlvmFunction {
    -- | The signature of this declared function.
    funcDecl      :: LlvmFunctionDecl,

    -- | The functions arguments
    funcArgs      :: [LMString],

    -- | The function attributes.
    funcAttrs     :: [LlvmFuncAttr],

    -- | The section to put the function into,
    funcSect      :: LMSection,

    -- | Prefix data
    funcPrefix    :: Maybe LlvmStatic,

    -- | The body of the functions.
    funcBody      :: LlvmBlocks
  }

type LlvmFunctions = [LlvmFunction]

type SingleThreaded = Bool

-- | LLVM ordering types for synchronization purposes. (Introduced in LLVM
-- 3.0). Please see the LLVM documentation for a better description.
data LlvmSyncOrdering
  -- | Some partial order of operations exists.
  = SyncUnord
  -- | A single total order for operations at a single address exists.
  | SyncMonotonic
  -- | Acquire synchronization operation.
  | SyncAcquire
  -- | Release synchronization operation.
  | SyncRelease
  -- | Acquire + Release synchronization operation.
  | SyncAcqRel
  -- | Full sequential Consistency operation.
  | SyncSeqCst
  deriving (Show, Eq)

-- | LLVM atomic operations. Please see the @atomicrmw@ instruction in
-- the LLVM documentation for a complete description.
data LlvmAtomicOp
  = LAO_Xchg
  | LAO_Add
  | LAO_Sub
  | LAO_And
  | LAO_Nand
  | LAO_Or
  | LAO_Xor
  | LAO_Max
  | LAO_Min
  | LAO_Umax
  | LAO_Umin
  deriving (Show, Eq)

-- | Llvm Statements
data LlvmStatement
  {- |
    Assign an expression to a variable:
      * dest:   Variable to assign to
      * source: Source expression
  -}
  = Assignment LlvmVar LlvmExpression

  {- |
    Memory fence operation
  -}
  | Fence Bool LlvmSyncOrdering

  {- |
    Always branch to the target label
  -}
  | Branch LlvmVar

  {- |
    Branch to label targetTrue if cond is true otherwise to label targetFalse
      * cond:        condition that will be tested, must be of type i1
      * targetTrue:  label to branch to if cond is true
      * targetFalse: label to branch to if cond is false
  -}
  | BranchIf LlvmVar LlvmVar LlvmVar

  {- |
    Comment
    Plain comment.
  -}
  | Comment [LMString]

  {- |
    Set a label on this position.
      * name: Identifier of this label, unique for this module
  -}
  | MkLabel LlvmBlockId

  {- |
    Store variable value in pointer ptr. If value is of type t then ptr must
    be of type t*.
      * value: Variable/Constant to store.
      * ptr:   Location to store the value in
  -}
  | Store LlvmVar LlvmVar

  {- |
    Multiway branch
      * scrutinee: Variable or constant which must be of integer type that is
                   determines which arm is chosen.
      * def:       The default label if there is no match in target.
      * target:    A list of (value,label) where the value is an integer
                   constant and label the corresponding label to jump to if the
                   scrutinee matches the value.
  -}
  | Switch LlvmVar LlvmVar [(LlvmVar, LlvmVar)]

  {- |
    Return a result.
      * result: The variable or constant to return
  -}
  | Return (Maybe LlvmVar)

  {- |
    An instruction for the optimizer that the code following is not reachable
  -}
  | Unreachable

  {- |
    Raise an expression to a statement (if don't want result or want to use
    Llvm unnamed values.
  -}
  | Expr LlvmExpression

  {- |
    A nop LLVM statement. Useful as its often more efficient to use this
    then to wrap LLvmStatement in a Just or [].
  -}
  | Nop

  {- |
    A LLVM statement with metadata attached to it.
  -}
  | MetaStmt [MetaAnnot] LlvmStatement

  deriving (Eq)

-- | Llvm Expressions
data LlvmExpression
  {- |
    Allocate amount * sizeof(tp) bytes on the stack
      * tp:     LlvmType to reserve room for
      * amount: The nr of tp's which must be allocated
  -}
  = Alloca LlvmType Int

  {- |
    Perform the machine operator op on the operands left and right
      * op:    operator
      * left:  left operand
      * right: right operand
  -}
  | LlvmOp LlvmMachOp LlvmVar LlvmVar

  {- |
    Perform a compare operation on the operands left and right
      * op:    operator
      * left:  left operand
      * right: right operand
  -}
  | Compare LlvmCmpOp LlvmVar LlvmVar

  {- |
    Extract a scalar element from a vector
      * val: The vector
      * idx: The index of the scalar within the vector
  -}
  | Extract LlvmVar LlvmVar

  {- |
    Extract a scalar element from a structure
      * val: The structure
      * idx: The index of the scalar within the structure
    Corresponds to "extractvalue" instruction.
  -}
  | ExtractV LlvmVar Int

  {- |
    Insert a scalar element into a vector
      * val:   The source vector
      * elt:   The scalar to insert
      * index: The index at which to insert the scalar
  -}
  | Insert LlvmVar LlvmVar LlvmVar

  {- |
    Allocate amount * sizeof(tp) bytes on the heap
      * tp:     LlvmType to reserve room for
      * amount: The nr of tp's which must be allocated
  -}
  | Malloc LlvmType Int

  {- |
    Load the value at location ptr
  -}
  | Load LlvmVar

  {- |
    Atomic load of the value at location ptr
  -}
  | ALoad LlvmSyncOrdering SingleThreaded LlvmVar

  {- |
    Navigate in a structure, selecting elements
      * inbound: Is the pointer inbounds? (computed pointer doesn't overflow)
      * ptr:     Location of the structure
      * indexes: A list of indexes to select the correct value.
  -}
  | GetElemPtr Bool LlvmVar [LlvmVar]

  {- |
    Cast the variable from to the to type. This is an abstraction of three
    cast operators in Llvm, inttoptr, ptrtoint and bitcast.
       * cast: Cast type
       * from: Variable to cast
       * to:   type to cast to
  -}
  | Cast LlvmCastOp LlvmVar LlvmType

  {- |
    Atomic read-modify-write operation
       * op:       Atomic operation
       * addr:     Address to modify
       * operand:  Operand to operation
       * ordering: Ordering requirement
  -}
  | AtomicRMW LlvmAtomicOp LlvmVar LlvmVar LlvmSyncOrdering

  {- |
    Compare-and-exchange operation
       * addr:     Address to modify
       * old:      Expected value
       * new:      New value
       * suc_ord:  Ordering required in success case
       * fail_ord: Ordering required in failure case, can be no stronger than
                   suc_ord

    Result is an @i1@, true if store was successful.
  -}
  | CmpXChg LlvmVar LlvmVar LlvmVar LlvmSyncOrdering LlvmSyncOrdering

  {- |
    Call a function. The result is the value of the expression.
      * tailJumps: CallType to signal if the function should be tail called
      * fnptrval:  An LLVM value containing a pointer to a function to be
                   invoked. Can be indirect. Should be LMFunction type.
      * args:      Concrete arguments for the parameters
      * attrs:     A list of function attributes for the call. Only NoReturn,
                   NoUnwind, ReadOnly and ReadNone are valid here.
  -}
  | Call LlvmCallType LlvmVar [LlvmVar] [LlvmFuncAttr]

  {- |
    Call a function as above but potentially taking metadata as arguments.
      * tailJumps: CallType to signal if the function should be tail called
      * fnptrval:  An LLVM value containing a pointer to a function to be
                   invoked. Can be indirect. Should be LMFunction type.
      * args:      Arguments that may include metadata.
      * attrs:     A list of function attributes for the call. Only NoReturn,
                   NoUnwind, ReadOnly and ReadNone are valid here.
  -}
  | CallM LlvmCallType LlvmVar [MetaExpr] [LlvmFuncAttr]

  {- |
    Merge variables from different basic blocks which are predecessors of this
    basic block in a new variable of type tp.
      * tp:         type of the merged variable, must match the types of the
                    predecessor variables.
      * predecessors: A list of variables and the basic block that they originate
                      from.
  -}
  | Phi LlvmType [(LlvmVar,LlvmVar)]

  {- |
    Inline assembly expression. Syntax is very similar to the style used by GCC.
      * assembly:    Actual inline assembly code.
      * constraints: Operand constraints.
      * return ty:   Return type of function.
      * vars:        Any variables involved in the assembly code.
      * sideeffect:  Does the expression have side effects not visible from the
                     constraints list.
      * alignstack:  Should the stack be conservatively aligned before this
                     expression is executed.
  -}
  | Asm LMString LMString LlvmType [LlvmVar] Bool Bool

  {- |
    A LLVM expression with metadata attached to it.
  -}
  | MExpr [MetaAnnot] LlvmExpression

  deriving (Eq)


{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Llvm.MetaData where

import GhcPrelude

import Llvm.Types
import Outputable

-- The LLVM Metadata System.
--
-- The LLVM metadata feature is poorly documented but roughly follows the
-- following design:
-- * Metadata can be constructed in a few different ways (See below).
-- * After which it can either be attached to LLVM statements to pass along
-- extra information to the optimizer and code generator OR specifically named
-- metadata has an affect on the whole module (i.e., linking behaviour).
--
--
-- # Constructing metadata
-- Metadata comes largely in three forms:
--
-- * Metadata expressions -- these are the raw metadata values that encode
--   information. They consist of metadata strings, metadata nodes, regular
--   LLVM values (both literals and references to global variables) and
--   metadata expressions (i.e., recursive data type). Some examples:
--     !{ !"hello", !0, i32 0 }
--     !{ !1, !{ i32 0 } }
--
-- * Metadata nodes -- global metadata variables that attach a metadata
--   expression to a number. For example:
--     !0 = !{ [<metadata expressions>] !}
--
-- * Named metadata -- global metadata variables that attach a metadata nodes
--   to a name. Used ONLY to communicated module level information to LLVM
--   through a meaningful name. For example:
--     !llvm.module.linkage = !{ !0, !1 }
--
--
-- # Using Metadata
-- Using metadata depends on the form it is in:
--
-- * Attach to instructions -- metadata can be attached to LLVM instructions
--   using a specific reference as follows:
--     %l = load i32* @glob, !nontemporal !10
--     %m = load i32* @glob, !nontemporal !{ i32 0, !{ i32 0 } }
--   Only metadata nodes or expressions can be attached, named metadata cannot.
--   Refer to LLVM documentation for which instructions take metadata and its
--   meaning.
--
-- * As arguments -- llvm functions can take metadata as arguments, for
--   example:
--     call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1)
--   As with instructions, only metadata nodes or expressions can be attached.
--
-- * As a named metadata -- Here the metadata is simply declared in global
--   scope using a specific name to communicate module level information to LLVM.
--   For example:
--     !llvm.module.linkage = !{ !0, !1 }
--

-- | A reference to an un-named metadata node.
newtype MetaId = MetaId Int
               deriving (Eq, Ord, Enum)

instance Outputable MetaId where
    ppr (MetaId n) = char '!' <> int n

-- | LLVM metadata expressions
data MetaExpr = MetaStr !LMString
              | MetaNode !MetaId
              | MetaVar !LlvmVar
              | MetaStruct [MetaExpr]
              deriving (Eq)

instance Outputable MetaExpr where
  ppr (MetaVar (LMLitVar (LMNullLit _))) = text "null"
  ppr (MetaStr    s ) = char '!' <> doubleQuotes (ftext s)
  ppr (MetaNode   n ) = ppr n
  ppr (MetaVar    v ) = ppr v
  ppr (MetaStruct es) = char '!' <> braces (ppCommaJoin es)

-- | Associates some metadata with a specific label for attaching to an
-- instruction.
data MetaAnnot = MetaAnnot LMString MetaExpr
               deriving (Eq)

-- | Metadata declarations. Metadata can only be declared in global scope.
data MetaDecl
    -- | Named metadata. Only used for communicating module information to
    -- LLVM. ('!name = !{ [!<n>] }' form).
    = MetaNamed !LMString [MetaId]
    -- | Metadata node declaration.
    -- ('!0 = metadata !{ <metadata expression> }' form).
    | MetaUnnamed !MetaId !MetaExpr


{-# LANGUAGE CPP #-}

--------------------------------------------------------------------------------
-- | Pretty print LLVM IR Code.
--

module Llvm.PpLlvm (

    -- * Top level LLVM objects.
    ppLlvmModule,
    ppLlvmComments,
    ppLlvmComment,
    ppLlvmGlobals,
    ppLlvmGlobal,
    ppLlvmAliases,
    ppLlvmAlias,
    ppLlvmMetas,
    ppLlvmMeta,
    ppLlvmFunctionDecls,
    ppLlvmFunctionDecl,
    ppLlvmFunctions,
    ppLlvmFunction,

    ) where

#include "HsVersions.h"

import GhcPrelude

import Llvm.AbsSyn
import Llvm.MetaData
import Llvm.Types

import Data.List ( intersperse )
import Outputable
import Unique
import FastString ( sLit )

--------------------------------------------------------------------------------
-- * Top Level Print functions
--------------------------------------------------------------------------------

-- | Print out a whole LLVM module.
ppLlvmModule :: LlvmModule -> SDoc
ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)
  = ppLlvmComments comments $+$ newLine
    $+$ ppLlvmAliases aliases $+$ newLine
    $+$ ppLlvmMetas meta $+$ newLine
    $+$ ppLlvmGlobals globals $+$ newLine
    $+$ ppLlvmFunctionDecls decls $+$ newLine
    $+$ ppLlvmFunctions funcs

-- | Print out a multi-line comment, can be inside a function or on its own
ppLlvmComments :: [LMString] -> SDoc
ppLlvmComments comments = vcat $ map ppLlvmComment comments

-- | Print out a comment, can be inside a function or on its own
ppLlvmComment :: LMString -> SDoc
ppLlvmComment com = semi <+> ftext com

-- | Print out a list of global mutable variable definitions
ppLlvmGlobals :: [LMGlobal] -> SDoc
ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls

-- | Print out a global mutable variable definition
ppLlvmGlobal :: LMGlobal -> SDoc
ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
    let sect = case x of
            Just x' -> text ", section" <+> doubleQuotes (ftext x')
            Nothing -> empty

        align = case a of
            Just a' -> text ", align" <+> int a'
            Nothing -> empty

        rhs = case dat of
            Just stat -> pprSpecialStatic stat
            Nothing   -> ppr (pLower $ getVarType var)

        -- Position of linkage is different for aliases.
        const = case c of
          Global   -> "global"
          Constant -> "constant"
          Alias    -> "alias"

    in ppAssignment var $ ppr link <+> text const <+> rhs <> sect <> align
       $+$ newLine

ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags ->
  error $ "Non Global var ppr as global! "
          ++ showSDoc dflags (ppr var) ++ " " ++ showSDoc dflags (ppr val)

-- | Print out a list of LLVM type aliases.
ppLlvmAliases :: [LlvmAlias] -> SDoc
ppLlvmAliases tys = vcat $ map ppLlvmAlias tys

-- | Print out an LLVM type alias.
ppLlvmAlias :: LlvmAlias -> SDoc
ppLlvmAlias (name, ty)
  = char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty

-- | Print out a list of LLVM metadata.
ppLlvmMetas :: [MetaDecl] -> SDoc
ppLlvmMetas metas = vcat $ map ppLlvmMeta metas

-- | Print out an LLVM metadata definition.
ppLlvmMeta :: MetaDecl -> SDoc
ppLlvmMeta (MetaUnnamed n m)
  = ppr n <+> equals <+> ppr m

ppLlvmMeta (MetaNamed n m)
  = exclamation <> ftext n <+> equals <+> exclamation <> braces nodes
  where
    nodes = hcat $ intersperse comma $ map ppr m

-- | Print out a list of function definitions.
ppLlvmFunctions :: LlvmFunctions -> SDoc
ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs

-- | Print out a function definition.
ppLlvmFunction :: LlvmFunction -> SDoc
ppLlvmFunction fun =
    let attrDoc = ppSpaceJoin (funcAttrs fun)
        secDoc = case funcSect fun of
                      Just s' -> text "section" <+> (doubleQuotes $ ftext s')
                      Nothing -> empty
        prefixDoc = case funcPrefix fun of
                        Just v  -> text "prefix" <+> ppr v
                        Nothing -> empty
    in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun)
        <+> attrDoc <+> secDoc <+> prefixDoc
        $+$ lbrace
        $+$ ppLlvmBlocks (funcBody fun)
        $+$ rbrace
        $+$ newLine
        $+$ newLine

-- | Print out a function definition header.
ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc
ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
  = let varg' = case varg of
                      VarArgs | null p    -> sLit "..."
                              | otherwise -> sLit ", ..."
                      _otherwise          -> sLit ""
        align = case a of
                     Just a' -> text " align " <> ppr a'
                     Nothing -> empty
        args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%'
                                    <> ftext n)
                    (zip p args)
    in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <>
        (hsep $ punctuate comma args') <> ptext varg' <> rparen <> align

-- | Print out a list of function declaration.
ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs

-- | Print out a function declaration.
-- Declarations define the function type but don't define the actual body of
-- the function.
ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc
ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
  = let varg' = case varg of
                      VarArgs | null p    -> sLit "..."
                              | otherwise -> sLit ", ..."
                      _otherwise          -> sLit ""
        align = case a of
                     Just a' -> text " align" <+> ppr a'
                     Nothing -> empty
        args = hcat $ intersperse (comma <> space) $
                  map (\(t,a) -> ppr t <+> ppSpaceJoin a) p
    in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <>
        ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine

-- | Print out a list of LLVM blocks.
ppLlvmBlocks :: LlvmBlocks -> SDoc
ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks

-- | Print out an LLVM block.
-- It must be part of a function definition.
ppLlvmBlock :: LlvmBlock -> SDoc
ppLlvmBlock (LlvmBlock blockId stmts) =
  let isLabel (MkLabel _) = True
      isLabel _           = False
      (block, rest)       = break isLabel stmts
      ppRest = case rest of
        MkLabel id:xs -> ppLlvmBlock (LlvmBlock id xs)
        _             -> empty
  in ppLlvmBlockLabel blockId
           $+$ (vcat $ map ppLlvmStatement block)
           $+$ newLine
           $+$ ppRest

-- | Print out an LLVM block label.
ppLlvmBlockLabel :: LlvmBlockId -> SDoc
ppLlvmBlockLabel id = pprUniqueAlways id <> colon

-- | Print out an LLVM statement.
ppLlvmStatement :: LlvmStatement -> SDoc
ppLlvmStatement stmt =
  let ind = (text "  " <>)
  in case stmt of
        Assignment  dst expr      -> ind $ ppAssignment dst (ppLlvmExpression expr)
        Fence       st ord        -> ind $ ppFence st ord
        Branch      target        -> ind $ ppBranch target
        BranchIf    cond ifT ifF  -> ind $ ppBranchIf cond ifT ifF
        Comment     comments      -> ind $ ppLlvmComments comments
        MkLabel     label         -> ppLlvmBlockLabel label
        Store       value ptr     -> ind $ ppStore value ptr
        Switch      scrut def tgs -> ind $ ppSwitch scrut def tgs
        Return      result        -> ind $ ppReturn result
        Expr        expr          -> ind $ ppLlvmExpression expr
        Unreachable               -> ind $ text "unreachable"
        Nop                       -> empty
        MetaStmt    meta s        -> ppMetaStatement meta s

-- | Print out an LLVM expression.
ppLlvmExpression :: LlvmExpression -> SDoc
ppLlvmExpression expr
  = case expr of
        Alloca     tp amount        -> ppAlloca tp amount
        LlvmOp     op left right    -> ppMachOp op left right
        Call       tp fp args attrs -> ppCall tp fp (map MetaVar args) attrs
        CallM      tp fp args attrs -> ppCall tp fp args attrs
        Cast       op from to       -> ppCast op from to
        Compare    op left right    -> ppCmpOp op left right
        Extract    vec idx          -> ppExtract vec idx
        ExtractV   struct idx       -> ppExtractV struct idx
        Insert     vec elt idx      -> ppInsert vec elt idx
        GetElemPtr inb ptr indexes  -> ppGetElementPtr inb ptr indexes
        Load       ptr              -> ppLoad ptr
        ALoad      ord st ptr       -> ppALoad ord st ptr
        Malloc     tp amount        -> ppMalloc tp amount
        AtomicRMW  aop tgt src ordering -> ppAtomicRMW aop tgt src ordering
        CmpXChg    addr old new s_ord f_ord -> ppCmpXChg addr old new s_ord f_ord
        Phi        tp predecessors  -> ppPhi tp predecessors
        Asm        asm c ty v se sk -> ppAsm asm c ty v se sk
        MExpr      meta expr        -> ppMetaExpr meta expr

--------------------------------------------------------------------------------
-- * Individual print functions
--------------------------------------------------------------------------------

-- | Should always be a function pointer. So a global var of function type
-- (since globals are always pointers) or a local var of pointer function type.
ppCall :: LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
ppCall ct fptr args attrs = case fptr of
                           --
    -- if local var function pointer, unwrap
    LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d

    -- should be function type otherwise
    LMGlobalVar _ (LMFunction d) _ _ _ _    -> ppCall' d

    -- not pointer or function, so error
    _other -> error $ "ppCall called with non LMFunction type!\nMust be "
                ++ " called with either global var of function type or "
                ++ "local var of pointer function type."

    where
        ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
            let tc = if ct == TailCall then text "tail " else empty
                ppValues = hsep $ punctuate comma $ map ppCallMetaExpr args
                ppArgTy  = (ppCommaJoin $ map fst params) <>
                           (case argTy of
                               VarArgs   -> text ", ..."
                               FixedArgs -> empty)
                fnty = space <> lparen <> ppArgTy <> rparen
                attrDoc = ppSpaceJoin attrs
            in  tc <> text "call" <+> ppr cc <+> ppr ret
                    <> fnty <+> ppName fptr <> lparen <+> ppValues
                    <+> rparen <+> attrDoc

        -- Metadata needs to be marked as having the `metadata` type when used
        -- in a call argument
        ppCallMetaExpr (MetaVar v) = ppr v
        ppCallMetaExpr v           = text "metadata" <+> ppr v

ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
ppMachOp op left right =
  (ppr op) <+> (ppr (getVarType left)) <+> ppName left
        <> comma <+> ppName right

ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
ppCmpOp op left right =
  let cmpOp
        | isInt (getVarType left) && isInt (getVarType right) = text "icmp"
        | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"
        | otherwise = text "icmp" -- Just continue as its much easier to debug
        {-
        | otherwise = error ("can't compare different types, left = "
                ++ (show $ getVarType left) ++ ", right = "
                ++ (show $ getVarType right))
        -}
  in cmpOp <+> ppr op <+> ppr (getVarType left)
        <+> ppName left <> comma <+> ppName right

ppAssignment :: LlvmVar -> SDoc -> SDoc
ppAssignment var expr = ppName var <+> equals <+> expr

ppFence :: Bool -> LlvmSyncOrdering -> SDoc
ppFence st ord =
  let singleThread = case st of True  -> text "singlethread"
                                False -> empty
  in text "fence" <+> singleThread <+> ppSyncOrdering ord

ppSyncOrdering :: LlvmSyncOrdering -> SDoc
ppSyncOrdering SyncUnord     = text "unordered"
ppSyncOrdering SyncMonotonic = text "monotonic"
ppSyncOrdering SyncAcquire   = text "acquire"
ppSyncOrdering SyncRelease   = text "release"
ppSyncOrdering SyncAcqRel    = text "acq_rel"
ppSyncOrdering SyncSeqCst    = text "seq_cst"

ppAtomicOp :: LlvmAtomicOp -> SDoc
ppAtomicOp LAO_Xchg = text "xchg"
ppAtomicOp LAO_Add  = text "add"
ppAtomicOp LAO_Sub  = text "sub"
ppAtomicOp LAO_And  = text "and"
ppAtomicOp LAO_Nand = text "nand"
ppAtomicOp LAO_Or   = text "or"
ppAtomicOp LAO_Xor  = text "xor"
ppAtomicOp LAO_Max  = text "max"
ppAtomicOp LAO_Min  = text "min"
ppAtomicOp LAO_Umax = text "umax"
ppAtomicOp LAO_Umin = text "umin"

ppAtomicRMW :: LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
ppAtomicRMW aop tgt src ordering =
  text "atomicrmw" <+> ppAtomicOp aop <+> ppr tgt <> comma
  <+> ppr src <+> ppSyncOrdering ordering

ppCmpXChg :: LlvmVar -> LlvmVar -> LlvmVar
          -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc
ppCmpXChg addr old new s_ord f_ord =
  text "cmpxchg" <+> ppr addr <> comma <+> ppr old <> comma <+> ppr new
  <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord

-- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but
-- we have no way of guaranteeing that this is true with GHC (we would need to
-- modify the layout of the stack and closures, change the storage manager,
-- etc.). So, we blindly tell LLVM that *any* vector store or load could be
-- unaligned. In the future we may be able to guarantee that certain vector
-- access patterns are aligned, in which case we will need a more granular way
-- of specifying alignment.

ppLoad :: LlvmVar -> SDoc
ppLoad var = text "load" <+> ppr derefType <> comma <+> ppr var <> align
  where
    derefType = pLower $ getVarType var
    align | isVector . pLower . getVarType $ var = text ", align 1"
          | otherwise = empty

ppALoad :: LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc
ppALoad ord st var = sdocWithDynFlags $ \dflags ->
  let alignment = (llvmWidthInBits dflags $ getVarType var) `quot` 8
      align     = text ", align" <+> ppr alignment
      sThreaded | st        = text " singlethread"
                | otherwise = empty
      derefType = pLower $ getVarType var
  in text "load atomic" <+> ppr derefType <> comma <+> ppr var <> sThreaded
            <+> ppSyncOrdering ord <> align

ppStore :: LlvmVar -> LlvmVar -> SDoc
ppStore val dst
    | isVecPtrVar dst = text "store" <+> ppr val <> comma <+> ppr dst <>
                        comma <+> text "align 1"
    | otherwise       = text "store" <+> ppr val <> comma <+> ppr dst
  where
    isVecPtrVar :: LlvmVar -> Bool
    isVecPtrVar = isVector . pLower . getVarType

ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
ppCast op from to
    =   ppr op
    <+> ppr (getVarType from) <+> ppName from
    <+> text "to"
    <+> ppr to

ppMalloc :: LlvmType -> Int -> SDoc
ppMalloc tp amount =
  let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
  in text "malloc" <+> ppr tp <> comma <+> ppr amount'

ppAlloca :: LlvmType -> Int -> SDoc
ppAlloca tp amount =
  let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
  in text "alloca" <+> ppr tp <> comma <+> ppr amount'

ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc
ppGetElementPtr inb ptr idx =
  let indexes = comma <+> ppCommaJoin idx
      inbound = if inb then text "inbounds" else empty
      derefType = pLower $ getVarType ptr
  in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppr ptr
                            <> indexes

ppReturn :: Maybe LlvmVar -> SDoc
ppReturn (Just var) = text "ret" <+> ppr var
ppReturn Nothing    = text "ret" <+> ppr LMVoid

ppBranch :: LlvmVar -> SDoc
ppBranch var = text "br" <+> ppr var

ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppBranchIf cond trueT falseT
  = text "br" <+> ppr cond <> comma <+> ppr trueT <> comma <+> ppr falseT

ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
ppPhi tp preds =
  let ppPreds (val, label) = brackets $ ppName val <> comma <+> ppName label
  in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds)

ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
ppSwitch scrut dflt targets =
  let ppTarget  (val, lab) = ppr val <> comma <+> ppr lab
      ppTargets  xs        = brackets $ vcat (map ppTarget xs)
  in text "switch" <+> ppr scrut <> comma <+> ppr dflt
        <+> ppTargets targets

ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
ppAsm asm constraints rty vars sideeffect alignstack =
  let asm'  = doubleQuotes $ ftext asm
      cons  = doubleQuotes $ ftext constraints
      rty'  = ppr rty
      vars' = lparen <+> ppCommaJoin vars <+> rparen
      side  = if sideeffect then text "sideeffect" else empty
      align = if alignstack then text "alignstack" else empty
  in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma
        <+> cons <> vars'

ppExtract :: LlvmVar -> LlvmVar -> SDoc
ppExtract vec idx =
    text "extractelement"
    <+> ppr (getVarType vec) <+> ppName vec <> comma
    <+> ppr idx

ppExtractV :: LlvmVar -> Int -> SDoc
ppExtractV struct idx =
    text "extractvalue"
    <+> ppr (getVarType struct) <+> ppName struct <> comma
    <+> ppr idx

ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppInsert vec elt idx =
    text "insertelement"
    <+> ppr (getVarType vec) <+> ppName vec <> comma
    <+> ppr (getVarType elt) <+> ppName elt <> comma
    <+> ppr idx

ppMetaStatement :: [MetaAnnot] -> LlvmStatement -> SDoc
ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetaAnnots meta

ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc
ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetaAnnots meta

ppMetaAnnots :: [MetaAnnot] -> SDoc
ppMetaAnnots meta = hcat $ map ppMeta meta
  where
    ppMeta (MetaAnnot name e)
        = comma <+> exclamation <> ftext name <+>
          case e of
            MetaNode n    -> ppr n
            MetaStruct ms -> exclamation <> braces (ppCommaJoin ms)
            other         -> exclamation <> braces (ppr other) -- possible?

--------------------------------------------------------------------------------
-- * Misc functions
--------------------------------------------------------------------------------

-- | Blank line.
newLine :: SDoc
newLine = empty

-- | Exclamation point.
exclamation :: SDoc
exclamation = char '!'