\ignore{
\begin{code}
module StgToGCode where

import Control.Monad (when,unless)
import Data.Char
import Data.List

import GCode as G
import GCodeSysDeps

import CoreSyn (isEvaldUnfolding)
import DataCon
import Digraph
import FastString
import ForeignCall
import Id
import IdInfo
import Literal
import Module as M 
import Name as N
import Outputable
import OrdList
import Panic
import PrimOp 
import StgSyn
import TyCon
import Type as T 
import TysPrim
import UniqSet
import Unique
import Util
import Maybes
import Var (localiseId,isExportedId,tyVarKind)
import VarEnv

#include "HsVersions.h"
\end{code}
}

\subsection{Code Generation Monad}

\begin{code}
newtype CgM a = CgM { runCgM :: IdEnv Loc -> (a,Stmnts,OrdList Closure) }

instance Monad CgM where
    return a = CgM $ \_ -> (a,nilOL,nilOL)
    m >>= k = CgM $ \env -> 
        let 
            (a,ss,cs) = runCgM m env
            (b,ss',cs') = runCgM (k a) env
        in (b,ss`appOL`ss',cs`appOL`cs')

cgFix :: (a -> CgM a) -> CgM a
cgFix k = CgM $ \env -> let (a,ss,cs) = runCgM (k a) env in (a,ss,cs)

cgStmnts :: Stmnts -> CgM ()
cgStmnts ss = CgM $ \_ -> ((),ss,nilOL)

cgForkEnv :: IdEnv Loc -> CgM a -> CgM (a,Stmnts)
cgForkEnv env m = let (x,ss,cs) = runCgM m env in CgM $ \_ -> ((x,ss),nilOL,cs)

cgClosure :: Closure -> CgM ()
cgClosure c = CgM $ \_ -> ((),nilOL,unitOL c)

cgEnv :: CgM (IdEnv Loc)
cgEnv = CgM $ \env -> (env,nilOL,nilOL)

cgExtend :: [(Id,Loc)] -> CgM a -> CgM a
cgExtend xs m = CgM $ \env -> runCgM m (env`extendVarEnvList`xs)

cgWithEnv :: IdEnv Loc -> CgM a -> CgM a
cgWithEnv env m = CgM $ \_ -> runCgM m env
\end{code}

\subsection{Code Generation Helpers}

\begin{code}
cgStmnt :: Stmnt -> CgM ()
cgStmnt = cgStmnts . unitOL

cgMove :: Loc -> Loc -> CgM ()
cgMove s d = cgStmnt (Move s d)

cgFork :: CgM a -> CgM (a,Stmnts)
cgFork m = do
    env <- cgEnv
    cgForkEnv env m

cgReturn :: [Loc] -> CgM ()
cgReturn xs = emitSimultaneously (toOL [Move src dst|(src,dst) <- allocRegs locType xs])

cgCall :: Call -> [Loc] -> CgM ()
cgCall call args = do
    cgReturn args -- We just happen to use the same conventing for calling and returning
    cgStmnt (Call call)
\end{code}

\subsection{Environment Stuff}

\begin{code}
varLoc :: Id -> CgM Loc
varLoc id = do
    env <- cgEnv
    return (lookupWithDefaultVarEnv env (transId id) id)

argLoc :: StgArg -> CgM Loc
argLoc (StgVarArg v) = varLoc v
argLoc (StgLitArg l) = return (G.Literal (transLit l))
argLoc a = pprPanic "argLoc" (ppr a)
\end{code}

\subsection{STG Translation}

\begin{code}
-- This returns an Id's "home location". This is a location reserved specifically for this Id. 
-- Note: Id's don't always live in their home location. Often we'll bind an Id to an offset
-- in a data constructor for example. You still need to lookup Ids in the environment. This
-- function is just used when we need to conjure up a location to store some Id in.
transId :: Id -> Loc
transId id
    | isGlobalId id 
    = let 
        qn = if isExternalName name 
                then transQualName name 
                else (nilFS,transOccName (mkLocalOcc (idUnique id)))
      in Global gty qn
    | otherwise = Var gty (idUnique id)
    where
        name = idName id
        gty =  transType (idType id)
\end{code}

\begin{code}
transModule :: M.Module -> [TyCon] -> [StgBinding] -> G.Module
transModule mod tycons binds = G.Module
    {m_name     = moduleNameFS (moduleName mod)
    ,m_globals  = [GlobalDecl n ty (isExportedId bndr)
                  |bind <- binds
                  ,bndr <- bindersOf bind
                  ,let Global ty (_,n) = ASSERT2(isGlobalId bndr,ppr bndr) transId bndr]
    ,m_exports  = [transExport id fexport 
                  |(id,FExportId fexport) <- [(id,globalIdDetails id) 
                                             |bind <- binds
                                             ,id <- bindersOf bind]]
    ,m_closures = fromOL cs
    ,m_init     = ss}
    where
        (_,ss,cs) = flip runCgM emptyVarEnv $ do
            sequence_ [transBinding bind >> cgStmnt (Trim emptyUniqSet)
                      |bind <- binds]
            mapM_ transTyCon tycons
        bindersOf (StgRec pairs) = [bndr | (bndr,_) <- pairs]
        bindersOf (StgNonRec bndr _) = [bndr]
\end{code}

\begin{code}
transTyCon :: TyCon -> CgM ()
transTyCon tc = mapM_ transDataCon (tyConDataCons tc)
\end{code}

\begin{code}
transDataCon :: DataCon -> CgM ()
transDataCon dc = cgClosure Closure
    {c_name    = transName (dataConName dc)
    ,c_payload = map transType (dataConRepArgTys dc)
    ,c_tag     = fromIntegral (dataConTag dc - fIRST_TAG)
    ,c_update  = SingleEntry
    ,c_code    = toOL [Move (Var ty thisUnique) (Reg ty 0),Return]}
    where
        ty = ClosureTy (transQualName (dataConName dc))
\end{code}

\subsection{Let Bindings}

\begin{code}
transBinding :: StgBinding -> CgM ()
transBinding bind = do
    rhss' <- mapM (uncurry transRhs) pairs
    sequence_ [cgStmnt (Alloc qn loc) >> when (isGlobalId bndr) (cgMove loc (transId bndr))
              |(bndr,(qn,_)) <- bndrs `zip` rhss'
              ,let loc = transId (localiseId bndr) `setLocType` ClosureTy qn]
    sequence_ [cgMove loc (Field node ty i)
              |(bndr,(qn,payload)) <- bndrs `zip` rhss'
              ,((loc,ty),i) <- payload `zip` [0..]
              ,let node = transId (localiseId bndr) `setLocType` ClosureTy qn]
    where
        bndrs = [bndr | (bndr,_) <- pairs]
        pairs = case bind of StgRec pairs -> pairs; StgNonRec bndr rhs -> [(bndr,rhs)]
\end{code}

\begin{code}
transRhs :: Id -> StgRhs -> CgM (QName,[(Loc,G.Type)])
\end{code}

\subsubsection{AP Thunks}

\begin{code}
transRhs _ (StgRhsClosure _ _ fvs upd _ [] (StgApp fun args))
    | args `lengthIs` (arity - 1)
    , all (not.isUnLiftedType.stgArgType) args
    , arity <= 7 
    = do
    payload <- mapM argLoc (StgVarArg fun : args)
    return ((mStdThunks,names!!arity),[(loc,LiftedTy)|loc<-payload])
    where
        arity = length fvs
        names -- Crude memoization
            | isUpdatable upd = [mkFastString ("stg_ap_" ++ show i ++ "_upd")|i<-[(0::Int)..]]
            | otherwise       = [mkFastString ("stg_ap_" ++ show i ++ "_noupd")|i<-[(0::Int)..]]
\end{code}

\subsubsection{Data Constructors}

\begin{code}
transRhs _ (StgRhsCon _ dc args) = do
    payload <- mapM argLoc args
    return (transQualName (dataConName dc),payload `zip` map transType (dataConRepArgTys dc))
\end{code}

\subsubsection{General Closures}

\begin{code}
transRhs bndr (StgRhsClosure _ _ fvs upd _ args body) = do
    payload <- mapM varLoc fvs'
    (_,code) <- cgForkEnv env $ do
        sequence_ [cgMove (Field this t i) (transId id)
                   >> cgMove (Literal (LNull t)) (Field this t i)
                  |(id,i) <- fvs' `zip` [0..]
                  ,let t = transType (idType id)
                  ,not (isReEntrant upd) && typeIsPtr t]
        transExpr body
        when (isUpdatable upd) (cgStmnt (Update (Reg LiftedTy 0)))
        cgStmnt Return
    cgClosure Closure
        {c_name=name
        ,c_payload=map (transType.idType) fvs'
        ,c_tag=fromIntegral (length args)
        ,c_update=upd
        ,c_code=code}
    return (qn,payload `zip` map (transType.idType) fvs')
    where
        qn@(_,name) = (nilFS,mkFastString (show (idUnique bndr)))
        this = Var (ClosureTy qn) thisUnique
        node_env
            | bndr `elem` fvs = unitVarEnv bndr this
            | otherwise = emptyVarEnv
        env = node_env
                `extendVarEnvList` [(v,Field this t i)
                                   |(v,i) <- fvs' `zip` [0..]
                                   , let t = transType (idType v)
                                   , isReEntrant upd || not (typeIsPtr t)]
                `extendVarEnvList` allocRegs (transType.idType) args
        fvs' = fvs \\ [bndr]
\end{code}

\begin{code}
transExpr :: StgExpr -> CgM ()
transExpr (StgApp f args) = transApp f args
transExpr (StgOpApp (StgPrimOp op ty_args) args) = transPrimOp op ty_args args
transExpr (StgOpApp (StgFCallOp fcall id) args) = transFCall fcall id args
transExpr (StgCase e liveVars saveVars bndr _ altType alts) = transCase e liveVars saveVars bndr altType alts
transExpr (StgLet stgBinding expr) = transBinding stgBinding >> transExpr expr
transExpr (StgLetNoEscape _ _ stgBinding expr) = transBinding stgBinding >> transExpr expr -- FEATURE: Stack allocate this
transExpr (StgLit l) = cgReturn [G.Literal (transLit l)]
transExpr e = pprPanic "transExpr" (ppr e)
\end{code}


\begin{code}
transApp :: Id -> [StgArg] -> CgM ()
transApp f []
    | isUnLiftedType (idType f) || isEvaldUnfolding (idUnfolding f) || idArity f > 0
    = varLoc f >>= \f' -> cgReturn [f']
    | maybeFunType (idType f)
    = varLoc f >>= \f_ -> cgCall (RtsCall FSLIT("stg_ap_0")) [f_]
    | otherwise
    = varLoc f >>= \f' -> cgCall (FunCall f') []
transApp f args 
    | Just con <- isDataConWorkId_maybe f, isUnboxedTupleCon con 
    = mapM argLoc args >>= \args' -> cgReturn args'
    | args `lengthIs` idArity f
    = varLoc f >>= \f' -> mapM argLoc args >>= \args' -> cgCall (FunCall f') args'
    | otherwise
    = varLoc f >>= \f' -> mapM argLoc args >>= \args' -> 
      cgSlowCall f' (args' `zip` map argUnique args)
    where
        argUnique (StgVarArg id) = idUnique id
        argUnique arg = pprPanic "transApp.argUnique" (ppr arg)
\end{code}

\begin{code}
cgSlowCall :: Loc -> [(Loc,Unique)] -> CgM ()
cgSlowCall f args = do
    later' <- mapM maybe_save later
    cgCall (RtsCall ap_name) ([loc|(loc,_) <- now] ++ [f])
    unless (null later') (cgSlowCall (Reg LiftedTy 0) later')
    where
        (ap_name,now,later) = matchSlowPattern (locType.fst) args
        maybe_save (loc,u)
            | volatile loc 
            = let loc' = Var (locType loc) u in cgMove loc loc' >> return (loc',u)
            | otherwise
            = return (loc,u)
\end{code}

\begin{code}
transPrimOp :: PrimOp -> [T.Type] -> [StgArg] -> CgM ()
transPrimOp op ty_args args
    | primOpImplOutOfLine op
    = mapM argLoc args >>= \args' -> cgCall (RtsCall (transOccName (primOpOcc op))) args'
    | isUnboxedTupleTyCon res_tc
    = mapM argLoc args >>= \args' -> cgStmnt (PrimOp op ty_args' args' ress)
    | isPrimTyCon res_tc
    = mapM argLoc args >>= \args' -> cgStmnt (PrimOp op ty_args' args' [res])
    | otherwise = pprPanic "transPrimOp" (ppr op)
    where
        ty_args' = map transType ty_args
        (_,res_ty) = splitFunTys (primOpType op `applyTys` ty_args)
        res = Reg (transType res_ty) 0
        (res_tc,res_args) = expectJust "transPrimOp" (splitTyConApp_maybe res_ty)
        ress = [reg | (_,reg) <- allocRegs transType res_args]
\end{code}

\begin{code}
-- Ugh... this is just different enough from above to need to be a separate function
transPrimOpInline :: PrimOp -> [T.Type] -> [StgArg] -> Id -> AltType -> [StgAlt] -> CgM ()
transPrimOpInline op ty_args args bndr alt_type alts
    | primOpImplOutOfLine op = pprPanic "transPrimOpInline" (ppr op)
    | isUnboxedTupleTyCon res_tc
    = mapM argLoc args >>= \args' -> cgStmnt (PrimOp op ty_args' args' ress) >> transExpr rhs
    | isPrimTyCon res_tc
    = mapM argLoc args >>= \args' -> cgStmnt (PrimOp op ty_args' args' [res]) >> transAlts bndr res alt_type alts
    | otherwise = pprPanic "transPrimOpInline" (ppr op)
    where
        ty_args' = map transType ty_args
        (_,res_ty) = splitFunTys (primOpType op `applyTys` ty_args)
        res = transId bndr
        (res_tc,_) = expectJust "transOp" (splitTyConApp_maybe res_ty)
        (_,bndrs,_,rhs) = only alts
        ress = map transId bndrs
\end{code}

\begin{code}
transFCall :: ForeignCall -> Id -> [StgArg] -> CgM ()
transFCall fcall id args
    = ASSERT(isUnboxedTupleTyCon res_tc) do
      mapM argLoc args >>= \args' -> cgStmnt (Foreign fcall (transSig (idType id)) args' ress)
    where
        (_,res_ty) = splitFunTys (idType id)
        (res_tc,res_args) = expectJust "transOp" (splitTyConApp_maybe res_ty)
        ress = [reg | (_,reg) <- allocRegs transType res_args]
\end{code}

\begin{code}
transCase :: StgExpr -> StgLiveVars -> StgLiveVars -> Id -> AltType -> [StgAlt] -> CgM ()
\end{code}

Special case #1: case of literal

\begin{code}
transCase (StgLit lit) _ _ bndr alt_type@(PrimAlt _) alts 
    = transAlts bndr (Literal (transLit lit)) alt_type alts
\end{code}

Special case #2: scrutinizing a primitive-typed variable

\begin{code}
transCase (StgApp v []) _ _ bndr alt_type@(PrimAlt _) alts 
    = ASSERT(isPrimitiveType (idType v))
      varLoc v >>= \v' -> cgMove v' bndr' >> transAlts bndr bndr' alt_type alts
    where
        bndr' = transId bndr
\end{code}

Special case #3: inline primops

\begin{code}
transCase (StgOpApp (StgPrimOp op ty_args) args) _ _ bndr alt_type alts 
    | not (primOpImplOutOfLine op)
    = transPrimOpInline op ty_args args bndr alt_type alts
\end{code}

Special case #4: inline foreign calls

\begin{code}
transCase (StgOpApp (StgFCallOp fcall id) args) _ _ _ _ alts
    | not (playSafe (foreignCallSafety fcall))
    = mapM argLoc args >>= \args' -> cgStmnt (Foreign fcall (transSig (idType id)) args' ress) >> transExpr rhs
    where
        (_,bndrs,_,rhs) = only alts
        ress = map transId bndrs
\end{code}

General case

\begin{code}
transCase e live_vars save_vars bndr alt_type alts = do
    live_locs <- mapM varLoc (uniqSetToList live_vars)
    cgStmnt (Trim (mkUniqSet [u | l <- live_locs, Var _ u <- l:locDeps l]))
    save_locs <- mapM varLoc (uniqSetToList save_vars)
    sequence_ [cgMove loc (transId v) | (v,loc) <- uniqSetToList save_vars `zip` save_locs, volatile loc]
    env <- cgEnv
    let env' = env `delVarEnvList` [v|(v,loc) <- uniqSetToList save_vars `zip` save_locs, volatile loc]
    cgWithEnv env' (transExpr e >> transAlts bndr res alt_type alts)
    where
        res = Reg (transType (idType bndr)) 0
\end{code}

\begin{code}
transAlts :: Id -> Loc -> AltType -> [StgAlt] -> CgM ()
transAlts bndr _ (UbxTupAlt _) alts
    = ASSERT(isDeadBinder bndr) cgExtend (allocRegs (transType.idType) bndrs) (transExpr rhs)
    where
        (_,bndrs,_,rhs) = only alts
transAlts bndr loc _ alts
    = mapM (cgFork . transAlt bndr loc) alts >>= \alts' -> case (alts,alts') of
        ((DEFAULT,_,_,_):_,(_,ss):arms) -> switch loc arms (Just ss)
        (_,arms) -> switch loc arms Nothing

transAlt :: Id -> Loc -> StgAlt -> CgM Tag
transAlt bndr loc (DataAlt dc,args,use_mask,rhs)
    | or use_mask
    = do
        cgMove (loc`setLocType`locType bndr') bndr'
        cgExtend [(a,Field bndr' (transType (idType a)) i)|(a,i) <- args `zip` [0..]] (transExpr rhs)
        return tag
    | otherwise = cgExtend [(bndr,loc)] (transExpr rhs) >> return tag
    where
        bndr' = transId bndr `setLocType` ClosureTy (transQualName (dataConName dc))
        tag = fromIntegral (dataConTag dc - fIRST_TAG)
transAlt bndr _ (LitAlt lit,_,_,rhs)
    | lit'@(LInt i) <- transLit lit
    = cgExtend [(bndr,Literal lit')] (transExpr rhs) >> return i
    | otherwise = pprPanic "transAlt" (ppr lit)
transAlt bndr loc (DEFAULT,_,_,rhs)
    = cgExtend [(bndr,loc)] (transExpr rhs) >> return (panic "transAlt")
\end{code}

\begin{code}
switch :: Loc -> [(Tag,Stmnts)] -> Maybe Stmnts -> CgM ()
switch _ [] Nothing = panic "switch"
switch _ [] (Just ss) = cgStmnts ss
switch x a Nothing = let (_,d) = last a in switch x (init a) (Just d)
switch x a (Just d) = cgStmnt (Switch x a d)
\end{code}

\begin{code}
transExport :: Id -> ForeignExport -> G.Export
transExport id fexport = Export name fexport (transSig (idType id))
    where
        Global _ (_,name) = ASSERT2(isGlobalId id,ppr id) transId id
\end{code}

\begin{code}
transSig :: T.Type -> Signature
transSig ty = ASSERT(isUnboxedTupleTyCon res_tc) (map transType arg_tys,map transType res_args)
    where
        (arg_tys,res_ty) = splitFunTys ty
        (res_tc,res_args) = expectJust "transSig" (splitTyConApp_maybe res_ty)
\end{code}

\begin{code}
transType :: T.Type -> G.Type
transType ty
    | Just (_ ,ty') <- splitForAllTy_maybe ty = transType ty'
    | Just ty' <- splitNewTypeRep_maybe ty  = transType ty'
    | Just (tc, tys) <- splitTyConApp_maybe ty, isPrimTyCon tc
    = ASSERT(tys `lengthIs` tyConArity tc) G.PrimTy tc (map transType tys)
    | Just tv <- getTyVar_maybe ty, isPtrTypeKind (tyVarKind tv) 
    = G.PrimTy stringPrimTyCon [] -- FIXME
    | otherwise
    = ASSERT2(isLiftedTypeKind (typeKind ty),ppr ty) LiftedTy
\end{code}

\begin{code}
transName :: N.Name -> G.Name
transName = transOccName . nameOccName

transOccName :: OccName -> G.Name
transOccName = zEncodeFS . occNameFS

transQualName :: N.Name -> G.QName
transQualName n = ASSERT(isExternalName n) (moduleNameFS (moduleName (nameModule n)),transName n)
\end{code}

\begin{code}
transLit :: Literal.Literal -> G.Literal
transLit (MachStr fs) = LString fs
transLit (MachInteger i tc) 
  | tc == int64PrimTyCon || tc == word64PrimTyCon
  = LLong (fromIntegral i)
  | otherwise
  = LInt (fromIntegral i)
transLit (MachRational r tc) 
  | tc == floatPrimTyCon = LFloat (fromRational r)
  | otherwise = LDouble (fromRational r)
transLit MachNullPtr = LNull (transType (literalType MachNullPtr))
transLit lit = pprPanic "transLit" (ppr lit)
\end{code}

\begin{code}
primOpImplOutOfLine :: PrimOp -> Bool
primOpImplOutOfLine NewArrayOp = False
primOpImplOutOfLine UnsafeThawArrayOp = False
primOpImplOutOfLine NewUArrayOp = False
primOpImplOutOfLine NewPinnedUArrayOp = False
primOpImplOutOfLine NewMutVarOp = False
primOpImplOutOfLine MyThreadIdOp = False
primOpImplOutOfLine op = primOpOutOfLine op
\end{code}


\begin{code}
-- Based on CgUtils.emitSimultaneously
emitSimultaneously :: Stmnts -> CgM ()
-- Emit code to perform the assignments in the
-- input simultaneously, using temporary variables when necessary.

-- We use the strongly-connected component algorithm, in which
--        * the vertices are the statements
--        * an edge goes from s1 to s2 iff
--                s1 assigns to something s2 uses
--          that is, if s1 should *follow* s2 in the final order

type CVertex = (Int, Stmnt)        -- Give each vertex a unique number,
                                -- for fast comparison

emitSimultaneously stmts
  = case filterOut isNopStmnt (fromOL stmts) of 
        -- Remove no-ops
      []        -> return ()
      [stmt]    -> cgStmnt stmt        -- It's often just one stmt
      stmt_list -> doSimultaneously1 (map mkPseudoUniqueC [1..]) (zip [(1::Int)..] stmt_list)

doSimultaneously1 :: [Unique] -> [CVertex] -> CgM ()
doSimultaneously1 us vertices
  = let
        edges = [ (vertex, key1, edges_from stmt1)
                | vertex@(key1, stmt1) <- vertices
                ]
        edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices, 
                                    stmt1 `mustFollow` stmt2
                           ]
        components = stronglyConnComp edges

        -- do_components deal with one strongly-connected component
        -- Not cyclic, or singleton?  Just do it
        do_component _ (AcyclicSCC (_,stmt))  = cgStmnt stmt
        do_component _ (CyclicSCC []) = panic "doSimultaneouslly1"
        do_component _ (CyclicSCC [(_,stmt)]) = cgStmnt stmt

                -- Cyclic?  Then go via temporaries.  Pick one to
                -- break the loop and try again with the rest.
        do_component us (CyclicSCC ((_,first_stmt) : rest))
          = do  { from_temp <- go_via_temp (head us) first_stmt
                ; doSimultaneously1 (tail us) rest
                ; cgStmnt from_temp }

        go_via_temp u (Move src dest)
          = do  { let tmp = Var (locType dest) u
                ; cgStmnt (Move src tmp)
                ; return (Move tmp dest) }
        go_via_temp _ s = pprPanic "go_via_temp" (ppr s)
    in
    sequence_ [do_component us c | (us,c) <- tails us `zip` components]

mustFollow :: Stmnt -> Stmnt -> Bool
mustFollow (Move _ d1) (Move s2 d2)
    | d1 `sameLoc` s2 = True
    | Just _ <- find (d1`sameLoc`) (locDeps s2) = True
    | Just _ <- find (d1`sameLoc`) (locDeps d2) = True
    | otherwise = False
mustFollow a b = pprPanic "mustFollow" (ppr a $$ ppr b)

isNopStmnt :: Stmnt -> Bool
isNopStmnt (Move src dst) = src `sameLoc` dst
isNopStmnt _ = False
\end{code}