module DDC.Core.Llvm.Convert
        ( convertModule
        , convertType
        , convertSuperType)
where
import DDC.Core.Llvm.Convert.Prim
import DDC.Core.Llvm.Convert.Type
import DDC.Core.Llvm.Convert.Atom
import DDC.Core.Llvm.Convert.Erase
import DDC.Core.Llvm.Metadata.Tbaa
import DDC.Core.Llvm.LlvmM
import DDC.Llvm.Syntax
import DDC.Core.Salt.Platform
import DDC.Core.Compounds
import DDC.Type.Env                             (KindEnv, TypeEnv)
import DDC.Type.Predicates
import DDC.Base.Pretty                          hiding (align)
import DDC.Data.ListUtils
import Control.Monad.State.Strict               (evalState)
import Control.Monad.State.Strict               (gets)
import Control.Monad
import Data.Maybe
import Data.Sequence                            (Seq, (<|), (|>), (><))
import Data.Map                                 (Map)
import Data.Set                                 (Set)
import qualified DDC.Llvm.Transform.Clean       as Llvm
import qualified DDC.Llvm.Transform.LinkPhi     as Llvm
import qualified DDC.Core.Salt                  as A
import qualified DDC.Core.Salt.Name             as A
import qualified DDC.Core.Module                as C
import qualified DDC.Core.Exp                   as C
import qualified DDC.Type.Env                   as Env
import qualified DDC.Core.Simplifier            as Simp
import qualified Data.Map                       as Map
import qualified Data.Set                       as Set
import qualified Data.Sequence                  as Seq
import qualified Data.Foldable                  as Seq


-- Module ---------------------------------------------------------------------
-- | Convert a Salt module to LLVM.
-- 
--   If anything goes wrong in the convertion then this function will
--   just call `error`.
--
convertModule :: Platform -> C.Module () A.Name -> Module
convertModule platform mm@(C.ModuleCore{})
 = {-# SCC convertModule #-}
   let  
        prims   = primDeclsMap platform
        state   = llvmStateInit platform prims

        -- Add extra Const and Distinct witnesses where possible.
        --  This helps us produce better LLVM metat data.
        mmElab   = evalState (Simp.applySimplifier 
                                        A.profile Env.empty Env.empty 
                                        (Simp.Trans Simp.Elaborate) mm)
                          state

        -- Convert to LLVM.
        --  The result contains ISet and INop meta instructions that need to be 
        --  cleaned out. We also need to fixup the labels in IPhi instructions.
        mmRaw    = evalState (convModuleM mmElab) state

        -- Inline the ISet meta instructions and drop INops.
        --  This gives us code that the LLVM compiler will accept directly.
        mmClean  = Llvm.clean   mmRaw

        -- Fixup the source labels in IPhi instructions.
        --  The converter itself sets these to 'undef', so we need to find the 
        --  real block label of each merged variable.
        mmPhi    = Llvm.linkPhi mmClean

   in   mmPhi


convModuleM :: C.Module () A.Name -> LlvmM Module
convModuleM mm@(C.ModuleCore{})
 | ([C.LRec bxs], _)    <- splitXLets $ C.moduleBody mm
 = do   platform        <- gets llvmStatePlatform

        -- The initial environments due to imported names.
        let kenv        = C.moduleKindEnv mm
        let tenv        = C.moduleTypeEnv mm `Env.union` (Env.fromList $ map fst bxs)

        -- Names of exported functions.
        --   We use a different linkage for exported functions.
        let nsExports   = Set.fromList $ Map.keys $ C.moduleExportTypes mm

        -- Forward declarations for imported functions.
        let Just importDecls 
                = sequence
                $ [ importedFunctionDeclOfType platform kenv External n t
                  | (n, t)   <- Map.elems $ C.moduleImportTypes mm ]

        -- Add RTS def -------------------------------------------------
        -- If this is the main module then we need to declare
        -- the global RTS state.
        let isMainModule 
                = C.moduleName mm == C.ModuleName ["Main"]

        -- Holds the pointer to the current top of the heap.
        --  This is the byte _after_ the last byte used by an object.
        let vHeapTop    = Var (NameGlobal "_DDC_Runtime_heapTop") (tAddr platform)

        -- Holds the pointer to the maximum heap.
        --  This is the byte _after_ the last byte avaiable in the heap.
        let vHeapMax    = Var (NameGlobal "_DDC_Runtime_heapMax") (tAddr platform)

        let rtsGlobals
                | isMainModule
                = [ GlobalStatic   vHeapTop (StaticLit (LitInt (tAddr platform) 0))
                  , GlobalStatic   vHeapMax (StaticLit (LitInt (tAddr platform) 0)) ]

                | otherwise
                = [ GlobalExternal vHeapTop 
                  , GlobalExternal vHeapMax ]

        ---------------------------------------------------------------
        (functions, mdecls)
                <- liftM unzip 
                $ mapM (uncurry (convSuperM nsExports kenv tenv)) bxs
        
        return  $ Module 
                { modComments   = []
                , modAliases    = [aObj platform]
                , modGlobals    = rtsGlobals
                , modFwdDecls   = primDecls platform ++ importDecls 
                , modFuncs      = functions 
                , modMDecls     = concat mdecls }

 | otherwise    = die "Invalid module"


-- | Global variables used directly by the converted code.
primDeclsMap :: Platform -> Map String FunctionDecl
primDeclsMap pp 
        = Map.fromList
        $ [ (declName decl, decl) | decl <- primDecls pp ]

primDecls :: Platform -> [FunctionDecl]
primDecls pp 
 = [    FunctionDecl
        { declName              = "malloc"
        , declLinkage           = External
        , declCallConv          = CC_Ccc
        , declReturnType        = tAddr pp
        , declParamListType     = FixedArgs
        , declParams            = [Param (tNat pp) []]
        , declAlign             = AlignBytes (platformAlignBytes pp) }

   ,    FunctionDecl
        { declName              = "abort"
        , declLinkage           = External
        , declCallConv          = CC_Ccc
        , declReturnType        = TVoid
        , declParamListType     = FixedArgs
        , declParams            = []
        , declAlign             = AlignBytes (platformAlignBytes pp) } ]


-- Super ----------------------------------------------------------------------
-- | Convert a top-level supercombinator to a LLVM function.
--   Region variables are completely stripped out.
convSuperM 
        :: Set A.Name           -- ^ Names exported from this module.
        -> KindEnv A.Name
        -> TypeEnv A.Name
        -> C.Bind  A.Name       -- ^ Bind of the top-level super.
        -> C.Exp () A.Name      -- ^ Super body.
        -> LlvmM (Function, [MDecl])

convSuperM nsExports kenv tenv bSuper@(C.BName nTop@(A.NameVar strTop) tSuper) x
 | Just (bfsParam, xBody)  <- takeXLamFlags x
 = do   
        platform         <- gets llvmStatePlatform

        -- Sanitise the super name so we can use it as a symbol
        -- in the object code.
        let nTop'       = A.sanitizeGlobal strTop

        -- Add parameters to environments.
        let bfsParam'    = eraseWitBinds bfsParam
        let bsParamType  = [b | (True,  b) <- bfsParam']
        let bsParamValue = [b | (False, b) <- bfsParam']

        let kenv'       =  Env.extends bsParamType  kenv
        let tenv'       =  Env.extends (bSuper : bsParamValue) tenv
        mdsup           <- deriveMD nTop' x

        -- Split off the argument and result types of the super.
        let (tsParam, tResult)   
                        = convertSuperType platform kenv tSuper
  
        -- Make parameter binders.
        let align       = AlignBytes (platformAlignBytes platform)

        -- Declaration of the super.
        let decl 
                = FunctionDecl 
                { declName               = nTop'

                  -- Set internal linkage for non-exported functions so that they
                  -- they won't conflict with functions of the same name that
                  -- might be defined in other modules.
                , declLinkage
                        = if Set.member nTop nsExports
                                then External
                                else Internal

                  -- ISSUE #266: Tailcall optimisation doesn't work for exported functions.
                  --   Using fast calls for non-exported functions enables the
                  --   LLVM tailcall optimisation. We can't enable this for exported
                  --   functions as well because we don't distinguish between DDC
                  --   generated functions and functions from the C libararies in 
                  --   our import specifications. We need a proper FFI system so that
                  --   we can get tailcalls for exported functions as well.
                , declCallConv           
                        = if Set.member nTop nsExports
                                then CC_Ccc
                                else CC_Fastcc

                , declReturnType         = tResult
                , declParamListType      = FixedArgs
                , declParams             = [Param t [] | t <- tsParam]
                , declAlign              = align }

        -- Convert function body to basic blocks.
        label   <- newUniqueLabel "entry"
        blocks  <- convBodyM BodyTop kenv' tenv' mdsup Seq.empty label Seq.empty xBody

        -- Build the function.
        return  $ ( Function
                    { funDecl     = decl
                    , funParams   = map nameOfParam $ filter (not . isBNone) bsParamValue
                    , funAttrs    = [] 
                    , funSection  = SectionAuto
                    , funBlocks   = Seq.toList blocks }
                  , decls mdsup )
                  

convSuperM _ _ _ _ _
        = die "Invalid super"


-- | Take the string name to use for a function parameter.
nameOfParam :: C.Bind A.Name -> String
nameOfParam bb
 = case bb of
        C.BName (A.NameVar n) _ 
           -> A.sanitizeName n

        _  -> die $ "Invalid parameter name: " ++ show bb


-- Body -----------------------------------------------------------------------
-- | What context we're doing this conversion in.
data BodyContext
        -- | Conversion at the top-level of a function.
        --   The expresison being converted must eventually pass control.
        = BodyTop

        -- | In a nested context, like in the right of a let-binding.
        --   The expression should produce a value that we assign to this
        --   variable, then jump to the provided label to continue evaluation.
        | BodyNest Var Label
        deriving Show


-- | Convert a function body to LLVM blocks.
convBodyM 
        :: BodyContext          -- ^ Context of this conversion.
        -> KindEnv A.Name
        -> TypeEnv A.Name
        -> MDSuper
        -> Seq Block            -- ^ Previous blocks.
        -> Label                -- ^ Id of current block.
        -> Seq AnnotInstr       -- ^ Instrs in current block.
        -> C.Exp () A.Name      -- ^ Expression being converted.
        -> LlvmM (Seq Block)    -- ^ Final blocks of function body.

convBodyM context kenv tenv mdsup blocks label instrs xx
 = do   pp      <- gets llvmStatePlatform
        case xx of

         -- Control transfer instructions -----------------
         -- Void return applied to a literal void constructor.
         --   We must be at the top-level of the function.
         C.XApp{}
          |  BodyTop                            <- context
          ,  Just (A.NamePrimOp p, xs)          <- takeXPrimApps xx
          ,  A.PrimControl A.PrimControlReturn  <- p
          ,  [C.XType _, C.XCon _ dc]           <- xs
          ,  Just A.NameLitVoid                 <- takeNameOfDaCon dc
          -> return  $   blocks 
                     |>  Block label 
                               (instrs |> (annotNil $ IReturn Nothing))

         -- Void return applied to some other expression.
         --   We still have to eval the expression, but it returns no value.
         --   We must be at the top-level of the function.
         C.XApp{}
          |  BodyTop                            <- context
          ,  Just (A.NamePrimOp p, xs)          <- takeXPrimApps xx
          ,  A.PrimControl A.PrimControlReturn  <- p
          ,  [C.XType t, x2]                    <- xs
          ,  isVoidT t
          -> do instrs2 <- convExpM ExpTop pp kenv tenv mdsup x2
                return  $  blocks
                        |> Block label 
                                 (instrs >< (instrs2 |> (annotNil $ IReturn Nothing)))

         -- Return a value.
         --   We must be at the top-level of the function.
         C.XApp{}
          |  BodyTop                            <- context
          ,  Just (A.NamePrimOp p, xs)          <- takeXPrimApps xx
          ,  A.PrimControl A.PrimControlReturn  <- p
          ,  [C.XType t, x]                     <- xs
          -> do let t'  =  convertType pp kenv t
                vDst    <- newUniqueVar t'
                is      <- convExpM (ExpAssign vDst) pp kenv tenv mdsup x
                return  $   blocks 
                        |>  Block label 
                                  (instrs >< (is |> (annotNil $ IReturn (Just (XVar vDst)))))

         -- Fail and abort the program.
         --   Allow this inside an expression as well as from the top level.
         C.XApp{}
          |  Just (A.NamePrimOp p, xs)         <- takeXPrimApps xx
          ,  A.PrimControl A.PrimControlFail   <- p
          ,  [C.XType _tResult]                <- xs
          -> let iFail  = ICall Nothing CallTypeStd Nothing 
                                TVoid (NameGlobal "abort") [] []

                 iSet   = case context of
                                BodyTop         -> INop
                                BodyNest vDst _ -> ISet vDst (XUndef (typeOfVar vDst))

                 block  = Block label
                        $ instrs |> annotNil iSet
                                 |> annotNil iFail 
                                 |> annotNil IUnreachable


             in  return  $   blocks |> block


         -- Calls -----------------------------------------
         -- Tailcall a function.
         --   We must be at the top-level of the function.
         C.XApp{}
          |  Just (A.NamePrimOp p, args)           <- takeXPrimApps xx
          ,  A.PrimCall (A.PrimCallTail arity)     <- p
          ,  _tsArgs                               <- take arity args
          ,  C.XType tResult : xFunTys : xsArgs    <- drop arity args
          ,  Just (xFun, _xsTys)        <- takeXApps xFunTys
          ,  Just (Var nFun _)          <- takeGlobalV pp kenv tenv xFun
          ,  Just xsArgs'               <- sequence $ map (mconvAtom pp kenv tenv) xsArgs
          -> if isVoidT tResult
              -- Tailcalled function returns void.
              then do return $ blocks
                        |> (Block label $ instrs
                           |> (annotNil $ ICall Nothing CallTypeTail Nothing
                                               (convertType pp kenv tResult) nFun xsArgs' [])
                           |> (annotNil $ IReturn Nothing))

              -- Tailcalled function returns an actual value.
              else do let tResult'    = convertType pp kenv tResult
                      vDst            <- newUniqueVar tResult'
                      return  $ blocks
                       |> (Block label $ instrs
                          |> (annotNil $ ICall (Just vDst) CallTypeTail Nothing
                                   (convertType pp kenv tResult) nFun xsArgs' [])
                          |> (annotNil $ IReturn (Just (XVar vDst))))


         -- Assignment ------------------------------------

         -- A statement of type void does not produce a value.
         C.XLet _ (C.LLet (C.BNone t) x1) x2
          | isVoidT t
          -> do instrs'   <- convExpM ExpTop pp kenv tenv mdsup x1
                convBodyM context kenv tenv mdsup blocks label
                        (instrs >< instrs') x2

         -- A non-void let-expression.
         --   In C we can just drop a computed value on the floor, 
         --   but the LLVM compiler needs an explicit name for it.
         --   Add the required name then call ourselves again.
         C.XLet a (C.LLet (C.BNone t) x1) x2
          | not $ isVoidT t
          -> do 
                n       <- newUnique
                let b   = C.BName (A.NameVar ("_dummy" ++ show n)) t

                convBodyM context kenv tenv mdsup blocks label instrs 
                        (C.XLet a (C.LLet b x1) x2)

         -- Variable assigment from a case-expression.
         C.XLet _ (C.LLet b@(C.BName (A.NameVar n) t) 
                            (C.XCase _ xScrut alts)) 
                  x2
          -> do 
                let t'    = convertType pp kenv t

                -- Assign result of case to this variable.
                let n'    = A.sanitizeName n
                let vCont = Var (NameLocal n') t'

                -- Label to jump to continue evaluating 'x1'
                lCont   <- newUniqueLabel "cont"

                let context'    = BodyNest vCont lCont
                blocksCase      <- convCaseM context' pp kenv tenv mdsup 
                                        label instrs xScrut alts

                let tenv'       = Env.extend b tenv
                convBodyM context kenv tenv' mdsup
                        (blocks >< blocksCase) 
                        lCont
                        Seq.empty
                        x2

         -- Variable assignment from an non-case expression.
         C.XLet _ (C.LLet b@(C.BName (A.NameVar n) t) x1) x2
          -> do let tenv' = Env.extend b tenv
                let n'    = A.sanitizeName n

                let t'    = convertType pp kenv t
                let dst   = Var (NameLocal n') t'
                instrs'   <- convExpM (ExpAssign dst) pp kenv tenv mdsup x1
                convBodyM context kenv tenv' mdsup blocks label (instrs >< instrs') x2


         -- Letregions ------------------------------------
         C.XLet _ (C.LLetRegions b _) x2
          -> do let kenv' = Env.extends b kenv
                convBodyM context kenv' tenv mdsup blocks label instrs x2

         -- Case ------------------------------------------
         C.XCase _ xScrut alts
          -> do blocks' <- convCaseM context pp kenv tenv mdsup 
                                label instrs xScrut alts

                return  $ blocks >< blocks'

        -- Cast -------------------------------------------
         C.XCast _ _ x
          -> convBodyM context kenv tenv mdsup blocks label instrs x

         _ 
          | BodyNest vDst label' <- context
          -> do instrs'  <- convExpM (ExpAssign vDst) pp kenv tenv mdsup xx
                return  $ blocks >< Seq.singleton (Block label 
                                (instrs >< (instrs' |> (annotNil $ IBranch label'))))

          |  otherwise
          -> die $   renderIndent
                 $   text "Invalid body statement " 
                 <$> ppr xx
 

-- Exp ------------------------------------------------------------------------
-- | What context we're doing this conversion in.
data ExpContext
        -- | Conversion at the top-level of the function.
        --   We don't have a variable to assign the result to, 
        --    so this must be a statement that transfers control
        = ExpTop        

        -- | Conversion in a context that expects a value.
        --   We evaluate the expression and assign the result to this variable.
        | ExpAssign Var
        deriving Show


-- | Take any assignable variable from an `ExpContext`.
varOfExpContext :: ExpContext -> Maybe Var
varOfExpContext xc
 = case xc of
        ExpTop          -> Nothing
        ExpAssign var   -> Just var


-- | Convert a simple Core expression to LLVM instructions.
--
--   This only works for variables, literals, and full applications of
--   primitive operators. The client should ensure the program is in this form 
--   before converting it. The result is just a sequence of instructions,
 --  so there are no new labels to jump to.
convExpM
        :: ExpContext
        -> Platform
        -> KindEnv A.Name
        -> TypeEnv A.Name
        -> MDSuper
        -> C.Exp () A.Name      -- ^ Expression to convert.
        -> LlvmM (Seq AnnotInstr)

convExpM context pp kenv tenv mdsup xx
 = case xx of
        C.XVar _ u@(C.UName (A.NameVar n))
         | Just t               <- Env.lookup u tenv
         , ExpAssign vDst       <- context
         -> do  let n'  = A.sanitizeName n
                let t'  = convertType pp kenv t
                return  $ Seq.singleton $ annotNil
                        $ ISet vDst (XVar (Var (NameLocal n') t'))
        
        C.XCon _ dc
         | Just n               <- takeNameOfDaCon dc
         , ExpAssign vDst       <- context
         -> case n of
                A.NameLitNat i
                 -> return $ Seq.singleton $ annotNil
                           $ ISet vDst (XLit (LitInt (tNat pp) i))

                A.NameLitInt  i
                 -> return $ Seq.singleton $ annotNil
                           $ ISet vDst (XLit (LitInt (tInt pp) i))

                A.NameLitWord w bits
                 -> return $ Seq.singleton $ annotNil
                           $ ISet vDst (XLit (LitInt (TInt $ fromIntegral bits) w))

                _ -> die "Invalid literal"

        C.XApp{}
         -- Call to primop.
         | Just (C.XVar _ (C.UPrim (A.NamePrimOp p) tPrim), args) <- takeXApps xx
         -> convPrimCallM pp kenv tenv mdsup
                        (varOfExpContext context)
                        p tPrim args

         -- Call to top-level super.
         | Just (xFun@(C.XVar _ u), xsArgs) <- takeXApps xx
         , Just (Var nFun _)                <- takeGlobalV pp kenv tenv xFun
         , Just xsArgs_value'    <- sequence $ map (mconvAtom pp kenv tenv) 
                                 $  eraseTypeWitArgs xsArgs
         , Just tSuper           <- Env.lookup u tenv
         -> let (_, tResult)    = convertSuperType pp kenv tSuper
            in  return $ Seq.singleton $ annotNil
                       $ ICall  (varOfExpContext context) CallTypeStd Nothing
                                tResult nFun xsArgs_value' []

        C.XCast _ _ x
         -> convExpM context pp kenv tenv mdsup x

        _ -> die $ "Invalid expression " ++ show xx


-- Case -----------------------------------------------------------------------
convCaseM 
        :: BodyContext
        -> Platform
        -> KindEnv A.Name
        -> TypeEnv A.Name
        -> MDSuper
        -> Label                -- label of current block
        -> Seq AnnotInstr       -- intrs to prepend to initial block.
        -> C.Exp () A.Name
        -> [C.Alt () A.Name]
        -> LlvmM (Seq Block)

convCaseM context pp kenv tenv mdsup label instrs xScrut alts 
 | Just vScrut'@Var{}   <- takeLocalV pp kenv tenv xScrut
 = do   
        -- Convert all the alternatives.
        -- If we're in a nested context we'll also get a block to join the 
        -- results of each alternative.
        (alts', blocksJoin)
                <- convAlts context pp kenv tenv mdsup alts

        -- Build the switch ---------------
        -- Determine what default alternative to use for the instruction. 
        (lDefault, blocksDefault)
         <- case last alts' of
                AltDefault l bs -> return (l, bs)
                AltCase _  l bs -> return (l, bs)

        -- Alts that aren't the default.
        let Just altsTable = takeInit alts'

        -- Build the jump table of non-default alts.
        let table       = mapMaybe takeAltCase altsTable
        let blocksTable = join $ fmap altResultBlocks $ Seq.fromList altsTable

        let switchBlock 
                =  Block label
                $  instrs 
                |> (annotNil $ ISwitch (XVar vScrut') lDefault table)

        return  $  switchBlock 
                <| (blocksTable >< blocksDefault >< blocksJoin)

convCaseM _ _ _ _ _ _ _ _ _
        = die "Invalid case expression"


-- Alts -----------------------------------------------------------------------
convAlts 
        :: BodyContext
        -> Platform
        -> KindEnv A.Name
        -> TypeEnv A.Name
        -> MDSuper
        -> [C.Alt () A.Name]
        -> LlvmM ([AltResult], Seq Block)

-- Alternatives are at top level.
convAlts BodyTop 
         _pp kenv tenv mdsup alts
 = do   
        alts'   <- mapM (convAltM BodyTop kenv tenv mdsup) alts
        return  (alts', Seq.empty)


-- If we're doing a branch inside a let-binding we need to add a join
-- point to collect the results from each altenative before continuing
-- on to evaluate the rest.
convAlts (BodyNest vDst lCont)
         _pp kenv tenv mdsup alts
 = do
        let tDst'       = typeOfVar vDst

        -- Label of the block that does the join.
        lJoin           <- newUniqueLabel "join"

        -- Convert all the alternatives,
        -- assiging their results into separate vars.
        (vDstAlts, alts'@(_:_))
                <- liftM unzip 
                $  mapM (\alt -> do
                        vDst'   <- newUniqueNamedVar "alt" tDst'
                        alt'    <- convAltM (BodyNest vDst' lJoin) kenv tenv mdsup alt
                        return (vDst', alt'))
                $  alts

        -- A block to join the result from each alternative.
        --  Trying to keep track of which block a variable is defined in is 
        --  too hard when we have nested join points. 
        --  Instead, we set the label here to 'unknown' and fix this up in the
        --  Clean transform.
        let blockJoin   
                = Block lJoin
                $ Seq.fromList $ map annotNil
                [ IPhi vDst  [ (XVar vDstAlt, Label "unknown")
                             | vDstAlt   <- vDstAlts ]
                , IBranch lCont ]

        return (alts', Seq.singleton blockJoin)


-- Alt ------------------------------------------------------------------------
-- | Holds the result of converting an alternative.
data AltResult
        = AltDefault        Label (Seq Block)
        | AltCase       Lit Label (Seq Block)


-- | Convert a case alternative to LLVM.
--
--   This only works for zero-arity constructors.
--   The client should extrac the fields of algebraic data objects manually.
convAltM 
        :: BodyContext          -- ^ Context we're converting in.
        -> KindEnv  A.Name      -- ^ Kind environment.
        -> TypeEnv  A.Name      -- ^ Type environment.
        -> MDSuper              -- ^ Meta-data for the enclosing super.
        -> C.Alt () A.Name      -- ^ Alternative to convert.
        -> LlvmM AltResult

convAltM context kenv tenv mdsup aa
 = do   pp      <- gets llvmStatePlatform
        case aa of
         C.AAlt C.PDefault x
          -> do label   <- newUniqueLabel "default"
                blocks  <- convBodyM context kenv tenv mdsup Seq.empty label Seq.empty x
                return  $  AltDefault label blocks

         C.AAlt (C.PData dc []) x
          | Just n      <- takeNameOfDaCon dc
          , Just lit    <- convPatName pp n
          -> do label   <- newUniqueLabel "alt"
                blocks  <- convBodyM context kenv tenv mdsup Seq.empty label Seq.empty x
                return  $  AltCase lit label blocks

         _ -> die "Invalid alternative"


-- | Convert a constructor name from a pattern to a LLVM literal.
--
--   Only integral-ish types can be used as patterns, for others 
--   such as Floats we rely on the Lite transform to have expanded
--   cases on float literals into a sequence of boolean checks.
convPatName :: Platform -> A.Name -> Maybe Lit
convPatName pp name
 = case name of
        A.NameLitBool True   -> Just $ LitInt (TInt 1) 1
        A.NameLitBool False  -> Just $ LitInt (TInt 1) 0

        A.NameLitNat  i      -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i

        A.NameLitInt  i      -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i

        A.NameLitWord i bits 
         | elem bits [8, 16, 32, 64]
         -> Just $ LitInt (TInt $ fromIntegral bits) i

        A.NameLitTag  i      -> Just $ LitInt (TInt (8 * platformTagBytes pp))  i

        _                    -> Nothing


-- | Take the blocks from an `AltResult`.
altResultBlocks :: AltResult -> Seq Block
altResultBlocks aa
 = case aa of
        AltDefault _ blocks     -> blocks
        AltCase _ _  blocks     -> blocks


-- | Take the `Lit` and `Label` from an `AltResult`
takeAltCase :: AltResult -> Maybe (Lit, Label)
takeAltCase (AltCase lit label _)       = Just (lit, label)
takeAltCase _                           = Nothing