ddc-core-llvm 0.4.1.3 → 0.4.2.1

raw patch · 36 files changed

+3087/−1685 lines, 36 filesdep +bytestringdep +textdep ~basedep ~ddc-basedep ~ddc-corePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring, text

Dependency ranges changed: base, ddc-base, ddc-core, ddc-core-salt, ddc-core-simpl, mtl

API changes (from Hackage documentation)

Files

• DDC/Core/Llvm/Convert.hs +110/−57
• DDC/Core/Llvm/Convert/Atom.hs +0/−106
• DDC/Core/Llvm/Convert/Base.hs +79/−0
• DDC/Core/Llvm/Convert/Context.hs +164/−0
• DDC/Core/Llvm/Convert/Erase.hs +0/−47
• DDC/Core/Llvm/Convert/Error.hs +158/−0
• DDC/Core/Llvm/Convert/Exp.hs +320/−387
• DDC/Core/Llvm/Convert/Exp/Atom.hs +283/−0
• DDC/Core/Llvm/Convert/Exp/Case.hs +206/−0
• DDC/Core/Llvm/Convert/Exp/PrimArith.hs +157/−0
• DDC/Core/Llvm/Convert/Exp/PrimCall.hs +56/−0
• DDC/Core/Llvm/Convert/Exp/PrimCast.hs +176/−0
• DDC/Core/Llvm/Convert/Exp/PrimStore.hs +309/−0
• DDC/Core/Llvm/Convert/Prim.hs +0/−454
• DDC/Core/Llvm/Convert/Super.hs +62/−58
• DDC/Core/Llvm/Convert/Type.hs +107/−90
• DDC/Core/Llvm/LlvmM.hs +0/−121
• DDC/Core/Llvm/Metadata/Graph.hs +12/−9
• DDC/Core/Llvm/Metadata/Tbaa.hs +18/−16
• DDC/Core/Llvm/Runtime.hs +34/−0
• DDC/Llvm/Analysis/Defs.hs +97/−0
• DDC/Llvm/Pretty/Exp.hs +36/−12
• DDC/Llvm/Pretty/Function.hs +1/−0
• DDC/Llvm/Pretty/Instr.hs +15/−7
• DDC/Llvm/Pretty/Prim.hs +0/−5
• DDC/Llvm/Pretty/Type.hs +1/−1
• DDC/Llvm/Syntax.hs +4/−0
• DDC/Llvm/Syntax/Exp.hs +121/−1
• DDC/Llvm/Syntax/Instr.hs +6/−12
• DDC/Llvm/Syntax/Prim.hs +10/−4
• DDC/Llvm/Transform/Calls.hs +74/−0
• DDC/Llvm/Transform/Clean.hs +0/−192
• DDC/Llvm/Transform/Flatten.hs +180/−0
• DDC/Llvm/Transform/LinkPhi.hs +0/−88
• DDC/Llvm/Transform/Simpl.hs +263/−0
• ddc-core-llvm.cabal +28/−18

@@ -4,86 +4,117 @@         , convertType         , convertSuperType) where+import DDC.Core.Llvm.Metadata.Tbaa+import DDC.Core.Llvm.Convert.Exp.Case+import DDC.Core.Llvm.Convert.Exp import DDC.Core.Llvm.Convert.Super import DDC.Core.Llvm.Convert.Type-import DDC.Core.Llvm.LlvmM-import DDC.Llvm.Syntax+import DDC.Core.Llvm.Convert.Base+import DDC.Core.Llvm.Runtime import DDC.Core.Salt.Platform-import DDC.Core.Compounds-import Control.Monad.State.Strict               (evalState)-import Control.Monad.State.Strict               (gets)+import DDC.Core.Exp.Annot.Compounds+import DDC.Llvm.Syntax+import DDC.Control.Monad.Check+import qualified Control.Monad.State.Strict     as State import Control.Monad import Data.Map                                 (Map)-import qualified DDC.Llvm.Transform.Clean       as Llvm-import qualified DDC.Llvm.Transform.LinkPhi     as Llvm++import qualified DDC.Llvm.Transform.Calls       as Calls+import qualified DDC.Llvm.Transform.Flatten     as Flatten+import qualified DDC.Llvm.Transform.Simpl       as Simpl+ import qualified DDC.Core.Salt                  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.List                      as List  -- | 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 +        -> C.Module () A.Name +        -> Either Error Module+ convertModule platform mm@(C.ModuleCore{})- = {-# SCC convertModule #-}-   let  -        prims   = primDeclsMap platform-        state   = llvmStateInit platform mm prims+ = let  +        state   = llvmStateInit           -- Add extra Const and Distinct witnesses where possible.-        --  This helps us produce better LLVM metat data.-        mmElab  = Simp.result -                $ evalState (Simp.applySimplifier -                                A.profile Env.empty Env.empty -                                (Simp.Trans Simp.Elaborate) mm)-                        state+        --  This helps us produce better LLVM metadata.+        mmElab  = Simp.result $ fst+                $ flip State.runState state+                $ Simp.applySimplifier +                        A.profile Env.empty Env.empty +                        (Simp.Trans Simp.Elaborate)+                        mm+                        +        -- Convert to LLVM.+   in   case runCheck state (convertModuleM platform mmElab) of+         (_state', Left  err)+          -> Left err -        stateElab = state { llvmStateModule = mmElab }+         (state', Right mmRaw)+          -> let +                -- Attach any top-level constants the code generator might have made.+                gsLit    = [ GlobalStatic var (StaticLit lit) +                           | (var, lit) <- Map.toList $ llvmConstants 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) stateElab+                mmConst  = mmRaw+                         { modGlobals = modGlobals mmRaw ++ gsLit } -        -- Inline the ISet meta instructions and drop INops.-        --  This gives us code that the LLVM compiler will accept directly.-        mmClean  = Llvm.clean   mmRaw+                -- Flatten out our extended expression language into raw LLVM instructions.+                mmFlat   = Flatten.flatten mmConst -        -- 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+                -- Clean out nops, v1 = v2 aliases and constant bindings.+                mmSimpl  = Simpl.simpl Simpl.configZero+                                { Simpl.configDropNops    = True+                                , Simpl.configSimplAlias  = True+                                , Simpl.configSimplConst  = True +                                , Simpl.configSquashUndef = True }+                                mmFlat -   in   mmPhi+                -- Attach calling conventions to call sites.+                mmCalls  = Calls.attachCallConvs mmSimpl +             in Right mmCalls -convModuleM :: C.Module () A.Name -> LlvmM Module-convModuleM mm@(C.ModuleCore{})- | ([C.LRec bxs], _)    <- splitXLets $ C.moduleBody mm- = do   platform        <- gets llvmStatePlatform +-- | Convert a Salt module to sugared LLVM.+--   The result contains ISet and INop meta-instructions that LLVM will not accept+--   directly. It also annotates IPhi nodes with undef, and these need to be given+--   real block labels before the LLVM compiler will accept them.+--+convertModuleM +        :: Platform+        -> C.Module () A.Name +        -> ConvertM Module++convertModuleM pp mm@(C.ModuleCore{})+ | ([C.LRec bxs], _)    <- splitXLets $ C.moduleBody mm+ = do            -- Globals for the runtime ---------------        --   If this is the main module then we define the globals-        --   for the runtime system at top-level.+        --   If this is the main module then we define the globals for the+        --   runtime system, otherwise tread them as external symbols.          -- 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__heapTop") (tAddr platform)+        let vHeapTop    = Var nameGlobalHeapTop (tAddr pp)          -- Holds the pointer to the maximum heap.         --  This is the byte _after_ the last byte avaiable in the heap.-        let vHeapMax    = Var (NameGlobal "_DDC__heapMax") (tAddr platform)+        let vHeapMax    = Var nameGlobalHeapMax (tAddr pp)          let globalsRts                 | C.moduleName mm == C.ModuleName ["Main"]-                = [ GlobalStatic   vHeapTop (StaticLit (LitInt (tAddr platform) 0))-                  , GlobalStatic   vHeapMax (StaticLit (LitInt (tAddr platform) 0)) ]+                = [ GlobalStatic   vHeapTop (StaticLit (LitInt (tAddr pp) 0))+                  , GlobalStatic   vHeapMax (StaticLit (LitInt (tAddr pp) 0)) ]                  | otherwise                 = [ GlobalExternal vHeapTop @@ -93,33 +124,55 @@         let kenv        = C.moduleKindEnv mm         let tenv        = C.moduleTypeEnv mm `Env.union` (Env.fromList $ map fst bxs) -        let Just importDecls +        let Just msImportDecls                  = sequence-                $ [ importedFunctionDeclOfType platform kenv +                $ [ importedFunctionDeclOfType pp kenv                          isrc-                        (lookup n (C.moduleExportValues mm))+                        (List.lookup n (C.moduleExportValues mm))                         n-                        (C.typeOfImportSource isrc)+                        (C.typeOfImportValue isrc)                   | (n, isrc)    <- C.moduleImportValues mm ] +        importDecls <- sequence msImportDecls -        -- Super-combinator definitions ---------+        -- Convert super definitions ---------         --   This is the code for locally defined functions.+        let ctx = Context+                { contextPlatform       = pp+                , contextModule         = mm+                , contextKindEnvTop     = kenv+                , contextTypeEnvTop     = tenv+                , contextSupers         = C.moduleTopBinds mm+                , contextImports        = Set.fromList $ map fst $ C.moduleImportValues mm+                , contextKindEnv        = kenv+                , contextTypeEnv        = tenv+                , contextNames          = Map.empty+                , contextMDSuper        = MDSuper Map.empty [] +                , contextSuperBinds     = Map.empty+                , contextPrimDecls      = primDeclsMap pp+                , contextConvertBody    = convertBody+                , contextConvertExp     = convertSimple+                , contextConvertCase    = convertCase }++        let convertSuper' ctx' b x+                = let Right x'  = A.fromAnnot x+                  in  convertSuper ctx' b x'+         (functions, mdecls)                 <- liftM unzip -                $ mapM (uncurry (convSuperM kenv tenv)) bxs-        +                $  mapM (uncurry (convertSuper' ctx)) bxs -        -- Paste everything together ------------+        -- Stitch everything together -----------         return  $ Module -                { modComments   = []-                , modAliases    = [aObj platform]-                , modGlobals    = globalsRts-                , modFwdDecls   = primDecls platform ++ importDecls -                , modFuncs      = functions -                , modMDecls     = concat mdecls }+                { modComments           = []+                , modAliases            = [aObj pp]+                , modGlobals            = globalsRts+                , modFwdDecls           = primDecls pp ++ importDecls +                , modFuncs              = functions +                , modMDecls             = concat mdecls } - | otherwise    = die "Invalid module"+ | otherwise    + = throw $ ErrorInvalidModule mm   -- | C library functions that are used directly by the generated code without

@@ -1,106 +0,0 @@--module DDC.Core.Llvm.Convert.Atom-        ( mconvAtom-        , mconvAtoms-        , takeLocalV-        , takeGlobalV)-where-import DDC.Llvm.Syntax-import DDC.Core.Llvm.Convert.Type-import DDC.Core.Salt.Platform-import DDC.Base.Pretty-import Control.Monad-import DDC.Type.Env                             (KindEnv, TypeEnv)-import qualified DDC.Type.Env                   as Env-import qualified DDC.Core.Salt                  as A-import qualified DDC.Core.Salt.Convert          as A-import qualified DDC.Core.Module                as C-import qualified DDC.Core.Exp                   as C----- Atoms ------------------------------------------------------------------------- | Take a variable or literal from an expression.---   These can be used directly in instructions.-mconvAtom -        :: Platform-        -> KindEnv A.Name-        -> TypeEnv A.Name-        -> C.Exp a A.Name-        -> Maybe Exp--mconvAtom pp kenv tenv xx- = case xx of--        -- Variables. Their names need to be sanitized before we write-        -- them to LLVM, as LLVM doesn't handle all the symbolic names-        -- that Disciple Core accepts.-        C.XVar _ u@(C.UName (A.NameVar n))-         |  Just t      <- Env.lookup u tenv-         -> let n'      = A.sanitizeName n-                t'      = convertType pp kenv t-            in  Just $ XVar (Var (NameLocal n') t')--        -- Literals. -        C.XCon _ dc-         | C.DaConPrim n t <- dc-         -> case n of-                A.NameLitBool b-                 -> let i | b           = 1-                          | otherwise   = 0-                    in Just $ XLit (LitInt (convertType pp kenv t) i)--                A.NameLitNat  nat   -> Just $ XLit (LitInt (convertType pp kenv t) nat)-                A.NameLitInt  val   -> Just $ XLit (LitInt (convertType pp kenv t) val)-                A.NameLitWord val _ -> Just $ XLit (LitInt (convertType pp kenv t) val)-                A.NameLitTag  tag   -> Just $ XLit (LitInt (convertType pp kenv t) tag)-                _                   -> Nothing--        _ -> Nothing----- | Convert several atoms to core.-mconvAtoms -        :: Platform-        -> KindEnv A.Name-        -> TypeEnv A.Name-        -> [C.Exp a A.Name]-        -> Maybe [Exp]--mconvAtoms pp kenv tenv xs-        = sequence $ map (mconvAtom pp kenv tenv) xs----- Utils ------------------------------------------------------------------------- | Take a variable from an expression as a local var, if any.-takeLocalV  -        :: Platform-        -> KindEnv A.Name  -> TypeEnv A.Name-        -> C.Exp a A.Name  -> Maybe Var--takeLocalV pp kenv tenv xx- = case xx of-        C.XVar _ u@(C.UName (A.NameVar str))-          |  Just t       <- Env.lookup u tenv-          -> Just $ Var (NameLocal str) (convertType pp kenv t)-        _ -> Nothing----- | Take a variable from an expression as a local var, if any.-takeGlobalV  -        :: Platform        -> C.Module () A.Name-        -> KindEnv A.Name  -> TypeEnv A.Name-        -> C.Exp a A.Name  -> Maybe Var--takeGlobalV pp mm kenv tenv xx- | C.XVar _ u@(C.UName nSuper)   <- xx- , Just t   <- Env.lookup u tenv- = let  -        mImport  = lookup nSuper (C.moduleImportValues mm)-        mExport  = lookup nSuper (C.moduleExportValues mm)-        Just str = liftM renderPlain $ A.seaNameOfSuper mImport mExport nSuper--   in   Just $ Var (NameGlobal str) (convertType pp kenv t)-        - | otherwise- = Nothing-

@@ -0,0 +1,79 @@++module DDC.Core.Llvm.Convert.Base+        ( ConvertM+        , LlvmState(..)+        , llvmStateInit ++          -- * Errors+        , Error (..)+        , throw++          -- * Uniques+        , newUnique+        , newUniqueVar+        , newUniqueNamedVar+        , newUniqueLabel)+where+import DDC.Core.Llvm.Convert.Error+import DDC.Llvm.Syntax+import DDC.Control.Monad.Check+import Data.Map                 (Map)+import qualified Data.Map       as Map+++-- ConvertM ---------------------------------------------------------------------------------------+-- | The toLLVM conversion monad.+type ConvertM = CheckM LlvmState Error+++-- LlvmState --------------------------------------------------------------------------------------+-- | State for the LLVM conversion.+data LlvmState+        = LlvmState+        { -- Unique name generator.+          llvmStateUnique       :: Int ++          -- String and array constants collected from the code during conversion.+          -- These get stored in statically allocated memory.+        , llvmConstants         :: Map Var Lit }+++-- | Initial LLVM state.+llvmStateInit :: LlvmState+llvmStateInit +        = LlvmState+        { llvmStateUnique       = 1  +        , llvmConstants         = Map.empty }+++-- Unique -----------------------------------------------------------------------------------------+-- | Unique name generation.+newUnique :: ConvertM Int+newUnique + = do   s       <- get+        let u   = llvmStateUnique s+        put     $ s { llvmStateUnique = u + 1 }+        return  $ u+++-- | Generate a new unique register variable with the specified `LlvmType`.+newUniqueVar :: Type -> ConvertM Var+newUniqueVar t+ = do   u <- newUnique+        return $ Var (NameLocal ("_v" ++ show u)) t+++-- | Generate a new unique named register variable with the specified `LlvmType`.+newUniqueNamedVar :: String -> Type -> ConvertM Var+newUniqueNamedVar name t+ = do   u <- newUnique +        return $ Var (NameLocal ("_v" ++ show u ++ "." ++ name)) t+++-- | Generate a new unique label.+newUniqueLabel :: String -> ConvertM Label+newUniqueLabel name+ = do   u <- newUnique+        return $ Label ("l" ++ show u ++ "." ++ name)++

@@ -0,0 +1,164 @@++module DDC.Core.Llvm.Convert.Context+        ( Context       (..)+        , extendKindEnv, extendsKindEnv+        , extendTypeEnv, extendsTypeEnv++        , ExpContext    (..)+        , AltResult     (..)+        , takeVarOfContext+        , takeNonVoidVarOfContext)+where+import DDC.Core.Salt.Platform+import DDC.Core.Llvm.Metadata.Tbaa+import DDC.Core.Llvm.Convert.Base+import DDC.Type.Exp+import DDC.Llvm.Syntax+import DDC.Type.Env                     (KindEnv, TypeEnv)+import Data.Sequence                    (Seq)+import Data.Set                         (Set)+import Data.Map                         (Map)+import qualified DDC.Core.Salt          as A+import qualified DDC.Core.Module        as C+import qualified DDC.Core.Exp           as C+import qualified DDC.Type.Env           as Env+++---------------------------------------------------------------------------------------------------+-- | Context of an Salt to LLVM conversion.+data Context +        = Context+        { -- | The platform that we're converting to, +          --   this sets the pointer width.+          contextPlatform       :: Platform++          -- | Surrounding module.+        , contextModule         :: C.Module () A.Name++          -- | The top-level kind environment.+        , contextKindEnvTop     :: KindEnv  A.Name++          -- | The top-level type environment.+        , contextTypeEnvTop     :: TypeEnv  A.Name++          -- | Names of imported supers that are defined in external modules.+          --   These are directly callable in the object code.+        , contextImports        :: Set      A.Name++          -- | Names of local supers that are defined in the current module.+          --   These are directly callable in the object code.+        , contextSupers         :: Set      A.Name++          -- | Current kind environment.+        , contextKindEnv        :: KindEnv  A.Name++          -- | Current type environment.+        , contextTypeEnv        :: TypeEnv  A.Name ++          -- | Map between core level variable names and LLVM names.+        , contextNames          :: Map A.Name Var++          -- | Super meta data+        , contextMDSuper        :: MDSuper ++          -- | C library functions that are used directly by the generated code without+          --   having an import declaration in the header of the converted module.+        , contextPrimDecls      :: Map String FunctionDecl++          -- | Re-bindings of top-level supers.+          --   This is used to handle let-expressions like 'f = g [t]' where+          --   'g' is a top-level super. See [Note: Binding top-level supers]+          --   Maps the right hand variable to the left hand one, eg g -> f,+          --   along with its type arguments.+        , contextSuperBinds+                :: Map A.Name (A.Name, [C.Type A.Name])++          -- Functions to convert the various parts of the AST.+          -- We tie the recursive knot though this Context type so that+          -- we can split the implementation into separate non-recursive modules.+        , contextConvertBody +                :: Context   -> ExpContext+                -> Seq Block -> Label+                -> Seq AnnotInstr+                -> A.Exp +                -> ConvertM (Seq Block)++        , contextConvertExp      +                :: Context  -> ExpContext+                -> A.Exp+                -> ConvertM (Seq AnnotInstr)++        , contextConvertCase+                :: Context  -> ExpContext+                -> Label+                -> Seq AnnotInstr+                -> A.Exp+                -> [A.Alt]+                -> ConvertM (Seq Block)+        }+++-- | Holds the result of converting an alternative.+data AltResult+        = AltDefault  Label (Seq Block)+        | AltCase Lit Label (Seq Block)+++-- | Extend the kind environment of a context with a new binding.+extendKindEnv  :: Bind A.Name  -> Context -> Context+extendKindEnv b ctx+        = ctx { contextKindEnv = Env.extend b (contextKindEnv ctx) }+++-- | Extend the kind environment of a context with some new bindings.+extendsKindEnv :: [Bind A.Name] -> Context -> Context+extendsKindEnv bs ctx+        = ctx { contextKindEnv = Env.extends bs (contextKindEnv ctx) }+++-- | Extend the type environment of a context with a new binding.+extendTypeEnv  :: Bind A.Name   -> Context -> Context+extendTypeEnv b ctx+        = ctx { contextTypeEnv = Env.extend b (contextTypeEnv ctx) }+++-- | Extend the type environment of a context with some new bindings.+extendsTypeEnv :: [Bind A.Name] -> Context -> Context+extendsTypeEnv bs ctx+        = ctx { contextTypeEnv = Env.extends bs (contextTypeEnv ctx) }+++---------------------------------------------------------------------------------------------------+-- | What expression context we're doing this conversion in.+data ExpContext+        -- | Conversion at the top-level of a function.+        --   The expresison being converted must eventually pass control.+        = ExpTop ++        -- | 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.+        | ExpNest   ExpContext Var Label++        -- | In a nested context where we need to assign the result+        --   to the given variable and fall through.+        | ExpAssign ExpContext Var+++-- | Take any assignable variable from a `Context`.+takeVarOfContext :: ExpContext -> Maybe Var+takeVarOfContext context+ = case context of+        ExpTop                  -> Nothing+        ExpNest _ var _         -> Just var+        ExpAssign _ var         -> Just var+++-- | Take any assignable variable from a `Context`, but only if it has a non-void type.+--   In LLVM we can't assign to void variables.+takeNonVoidVarOfContext :: ExpContext -> Maybe Var+takeNonVoidVarOfContext context+ = case takeVarOfContext context of+        Just (Var _ TVoid)       -> Nothing+        mv                       -> mv+

@@ -1,47 +0,0 @@--module DDC.Core.Llvm.Convert.Erase-        ( eraseTypeWitArgs-        , eraseXLAMs-        , eraseWitTApps -        , eraseWitBinds )-where-import DDC.Type.Predicates-import DDC.Core.Exp-import DDC.Core.Transform.TransformUpX----- | Erase type and witness arge Slurp out only the values from a list of---   function arguments.-eraseTypeWitArgs :: [Exp a n] -> [Exp a n]-eraseTypeWitArgs []       = []-eraseTypeWitArgs (x:xs)- = case x of-        XType{}       -> eraseTypeWitArgs xs-        XWitness{}    -> eraseTypeWitArgs xs-        _               -> x : eraseTypeWitArgs xs----- | Erase all `XLAM` binders from an expression.-eraseXLAMs :: Ord n => Exp a n -> Exp a n-eraseXLAMs -        = transformUpX' -        $ \x -> case x of-                 XLAM _ _ x'    -> x'-                 _              -> x---eraseWitTApps :: Type n -> Type n-eraseWitTApps tt- = case tt of-        TApp (TApp (TCon (TyConWitness _)) _) t -> eraseWitTApps t-        _                                       -> tt----- | Erase witness bindings-eraseWitBinds :: Eq n => [(Bool, Bind n)] -> [(Bool, Bind n)]-eraseWitBinds- = let isBindWit (_, b) -          = case b of-                 BName _ t | isWitnessType t -> True-                 _                           -> False-   in  filter (not . isBindWit)

@@ -0,0 +1,158 @@++module DDC.Core.Llvm.Convert.Error+        (Error (..))+where+import DDC.Core.Module+import DDC.Core.Exp+import DDC.Base.Pretty+import DDC.Core.Exp.Generic.Pretty      ()+import Data.Maybe+import qualified DDC.Core.Salt          as A+++-- | Things that can go wrong when converting Salt to Llvm code.+--+--   As user should only hit most of these in the case of compiler errors,+--   or with hand-crafted Salt programs, most of these just an expression+--   and a simple compilaint.+--+--   Some of the other errors, like for bad type promotions and truncations,+--   can be caused by source language expessions, so we include more+--   information. We leave it to the LLVM conversion to catch these because+--   the decision of whether the conversion is valid is platform dependent.+--+--   IMPORTANT: Whether or not particular machine primitives are supported is+--   really platform dependent. Fallback implementations for unsupported+--   primitives should be implemented in a Salt-level or Source-level library,+--   and not here in the code generator.+--+data Error +        -- Generic errors that should only be possible by compiling a+        -- hand-crafted Salt program.++        -- | Invalid Salt Bound.+        = ErrorInvalidBound+        { errorBound    :: Bound A.Name+        , errorDetails  :: Maybe String }++        -- | Invalid Salt Bind.+        | ErrorInvalidBind+        { errorBind     :: Bind A.Name+        , errorDetails  :: Maybe String }++        -- | Invalid Salt type.+        | ErrorInvalidType+        { errorType     :: Type A.Name+        , errorDetails  :: Maybe String }++        -- | Invalid Salt type constructor.+        | ErrorInvalidTyCon+        { errorTyCon    :: TyCon A.Name +        , errorDetails  :: Maybe String }++        -- | Invalid Salt expression.+        | ErrorInvalidExp+        { errorExp      :: A.Exp+        , errorDetails  :: Maybe String }++        -- | Invalid Salt alternative.+        | ErrorInvalidAlt+        { errorAlt      :: [A.Alt]+        , errorDetails  :: Maybe String }++        -- | Invalid Super+        | ErrorInvalidSuper+        { errorBind     :: Bind A.Name+        , errorExp      :: A.Exp }++        -- | Invalid Module+        | ErrorInvalidModule+        { errorModule   :: Module () A.Name }++        -- Platform specific errors that might arise in otherwise well-typed+        -- source programs. ++        -- | The size# primitive was applied to an invalid type.+        | ErrorInvalidSizeType+        { errorType     :: Type A.Name }++        -- | The size2# primitive was applied to an invalid type.+        | ErrorInvalidSize2Type+        { errorType     :: Type A.Name }++        -- | This use of convert# is not valid on this platform.+        | ErrorInvalidConversion+        { errorTypeFrom :: Type A.Name+        , errorTypeTo   :: Type A.Name }++        -- | This use of promote# is not valid on this platform.+        | ErrorInvalidPromotion+        { errorTypeFrom :: Type A.Name+        , errorTypeTo   :: Type A.Name }++        -- | This use of truncate# is not valid on this platform.+        | ErrorInvalidTruncation+        { errorTypeFrom :: Type A.Name+        , errorTypeTo   :: Type A.Name }++        -- | Arithmetic or logic primop cannot be used at this type.+        | ErrorInvalidArith+        { errorPrimArith :: A.PrimArith+        , errorType      :: Type A.Name }+        deriving Show+++instance Pretty Error where++ ppr (ErrorInvalidBound u md)+  = vcat [ text "Invalid bound: "       <> ppr u +         , text $ fromMaybe "" md ]++ ppr (ErrorInvalidBind b md)+  = vcat [ text "Invalid bind: "        <> ppr b+         , text $ fromMaybe "" md ]++ ppr (ErrorInvalidType t md)+  = vcat [ text "Invalid type: "        <> ppr t+         , text $ fromMaybe "" md ]++ ppr (ErrorInvalidTyCon tc md)+  = vcat [ text "Invalid type constructor: " <> ppr tc+         , text $ fromMaybe "" md ]++ ppr (ErrorInvalidExp x md)+  = vcat [ text "Invalid exp: "         <> ppr x+         , text $ fromMaybe "" md ]++ ppr (ErrorInvalidAlt alts md)+  = vcat [ text "Invalid alts: "        <> ppr alts+         , text $ fromMaybe "" md ]++ ppr (ErrorInvalidSuper _n _x)+  = vcat [ text "Invalid super." ]++ ppr (ErrorInvalidModule _m)+  = vcat [ text "Invalid module." ] ++ ppr (ErrorInvalidSizeType t)+  = vcat [ text "Cannot apply size# to type '"          <> ppr t <> text "'" ]++ ppr (ErrorInvalidSize2Type t)+  = vcat [ text "Cannot apply size2# to type '"         <> ppr t <> text "'" ]++ ppr (ErrorInvalidConversion tSrc tDst)+  = vcat [ text "Cannot convert# value of type '"       <> ppr tSrc +                <> text "' to '"                        <> ppr tDst <> text "'" ]++ ppr (ErrorInvalidPromotion tSrc tDst)+  = vcat [ text "Cannot promote# value of type '"       <> ppr tSrc +                <> text "' to '"                        <> ppr tDst <> text "'" ]++ ppr (ErrorInvalidTruncation tSrc tDst)+  = vcat [ text "Cannot truncate# value of type '"      <> ppr tSrc +                <> text "' to '"                        <> ppr tDst <> text "'" ]++ ppr (ErrorInvalidArith n t)+  = vcat [ text "Cannot use " <> ppr n+                <> text " at type '" <> ppr t <> text "'" ]+

@@ -1,71 +1,58 @@  module DDC.Core.Llvm.Convert.Exp-        ( BodyContext (..)-        , convBodyM)+        ( Context (..)+        , convertBody+        , convertSimple+        , bindLocalA, bindLocalAs) where-import DDC.Core.Llvm.Convert.Prim+import DDC.Core.Llvm.Convert.Exp.PrimCall+import DDC.Core.Llvm.Convert.Exp.PrimArith+import DDC.Core.Llvm.Convert.Exp.PrimCast+import DDC.Core.Llvm.Convert.Exp.PrimStore+import DDC.Core.Llvm.Convert.Exp.Atom+import DDC.Core.Llvm.Convert.Context 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.Core.Llvm.Convert.Base import DDC.Llvm.Syntax-import DDC.Core.Salt.Platform-import DDC.Core.Compounds-import DDC.Type.Env                             (KindEnv, TypeEnv)-import DDC.Base.Pretty                          hiding (align)-import DDC.Data.ListUtils-import Control.Monad.State.Strict               (gets)-import Control.Monad-import Data.Maybe-import Data.Sequence                            (Seq, (<|), (|>), (><))+import DDC.Core.Exp.Generic.Compounds+import Control.Applicative+import Data.Sequence                            (Seq, (|>), (><)) import qualified DDC.Core.Salt                  as A-import qualified DDC.Core.Salt.Convert          as A import qualified DDC.Core.Exp                   as C import qualified DDC.Type.Env                   as Env import qualified Data.Sequence                  as Seq----- 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+import qualified Data.Set                       as Set+import qualified Data.Map                       as Map  +--------------------------------------------------------------------------------------------------- -- | Convert a function body to LLVM blocks.-convBodyM -        :: BodyContext          -- ^ Context of this conversion.-        -> KindEnv A.Name-        -> TypeEnv A.Name-        -> MDSuper+convertBody+        :: Context+        -> ExpContext         -> 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.+        -> A.Exp                -- ^ Expression being converted.+        -> ConvertM (Seq Block) -- ^ Final blocks of function body. -convBodyM context kenv tenv mdsup blocks label instrs xx- = do   pp      <- gets llvmStatePlatform-        mm      <- gets llvmStateModule+convertBody ctx ectx blocks label instrs xx+ = let  pp           = contextPlatform    ctx +        kenv         = contextKindEnv     ctx+        convertCase  = contextConvertCase ctx+        atomsR as' = sequence $ map (mconvArg ctx) as'+   in do            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.XApp{}+          |  ExpTop{}                           <- ectx+          ,  Just (p, as)                       <- takeXPrimApps xx           ,  A.PrimControl A.PrimControlReturn  <- p-          ,  [C.XType{}, C.XCon _ dc]           <- xs-          ,  Just A.NameLitVoid                 <- takeNameOfDaCon dc+          ,  [A.RType{}, A.RExp (A.XCon dc)]    <- as+          ,  Just (A.NamePrimLit A.PrimLitVoid) <- takeNameOfDaCon dc           -> return  $   blocks                       |>  Block label                                 (instrs |> (annotNil $ IReturn Nothing))@@ -73,43 +60,45 @@          -- 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.XApp{}+          |  ExpTop{}                           <- ectx+          ,  Just (p, as)                       <- takeXPrimApps xx           ,  A.PrimControl A.PrimControlReturn  <- p-          ,  [C.XType _ t, x2]                  <- xs+          ,  [A.RType t, A.RExp x2]             <- as           ,  isVoidT t-          -> do instrs2 <- convExpM ExpTop pp kenv tenv mdsup x2+          -> do instrs2 <- convertSimple ctx ectx 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.XApp{}+          |  ExpTop{}                           <- ectx+          ,  Just (p, as)                       <- takeXPrimApps xx           ,  A.PrimControl A.PrimControlReturn  <- p-          ,  [C.XType _ t, x]                   <- xs-          -> do let t'  =  convertType pp kenv t+          ,  [A.RType t, A.RExp x]              <- as+          -> do t'      <- convertType pp kenv t                 vDst    <- newUniqueVar t'-                is      <- convExpM (ExpAssign vDst) pp kenv tenv mdsup x+                is      <- convertSimple ctx (ExpAssign ectx vDst) 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") [] []+         A.XApp{}+          |  Just (p, as)                       <- takeXPrimApps xx+          ,  A.PrimControl A.PrimControlFail    <- p+          ,  [A.RType _tResult]                 <- as+          -> let +                 iSet   = case ectx of+                           ExpTop{}           -> INop+                           ExpNest _ vDst _   -> ISet vDst (XUndef (typeOfVar vDst))+                           ExpAssign _ vDst   -> ISet vDst (XUndef (typeOfVar vDst)) -                 iSet   = case context of-                                BodyTop         -> INop-                                BodyNest vDst _ -> ISet vDst (XUndef (typeOfVar vDst))+                 iFail  = ICall Nothing CallTypeStd Nothing +                                TVoid (NameGlobal "abort") [] []                   block  = Block label                         $ instrs |> annotNil iSet@@ -117,387 +106,331 @@                                  |> annotNil IUnreachable  -             in  return  $   blocks |> block+             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 mm 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))+         A.XApp{}+          |  Just (p, args)                     <- takeXPrimApps xx+          ,  A.PrimCall (A.PrimCallTail arity)  <- p+          ,  _tsArgs                            <- take arity args+          ,  A.RType tResult : A.RExp xFunTys : xsArgs +                                                <- drop arity args+          ,  (xFun, _xsTys)                     <- splitXApps xFunTys+          ,  Just mFun                          <- takeGlobalV ctx xFun+          ,  Just msArgs                        <- sequence $ map (mconvArg ctx) xsArgs+          -> do +                Var nFun _      <- mFun+                xsArgs'         <- sequence msArgs+                tResult'        <- convertType pp kenv tResult+                if isVoidT tResult+                  -- Tail called function returns void.+                  then do+                        return $ blocks+                         |> (Block label $ instrs+                            |> (annotNil $ ICall Nothing CallTypeTail Nothing+                                                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))))+                  -- Tail called function returns an actual value.+                  else do +                        vDst      <- newUniqueVar tResult'+                        return  $ blocks+                         |> (Block label $ instrs+                            |> (annotNil $ ICall (Just vDst) CallTypeTail Nothing+                                                tResult' nFun xsArgs' [])+                            |> (annotNil $ IReturn (Just (XVar vDst))))            -- Assignment ------------------------------------+         -- Read from a pointer, with integrated bounds check.+         A.XLet (A.LLet (C.BName nDst _) x1) x2+          | Just (p, as)                         <- takeXPrimApps x1+          , A.PrimStore A.PrimStorePeekBounded   <- p+          , A.RType{} : A.RType tDst : args      <- as+          , Just [mPtr, mOffset, mLength]        <- atomsR args+          -> do+                tDst'           <- convertType pp kenv tDst+                (ctx', vDst@(Var nDst' _))    +                                <- bindLocalV ctx nDst tDst -         -- 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+                xPtr'           <- mPtr+                xOffset'        <- mOffset+                xLength'        <- mLength+                let vTest       =  Var (bumpName nDst' "test")  (TInt  1)+                let vAddr1      =  Var (bumpName nDst' "addr1") (tAddr pp)+                let vAddr2      =  Var (bumpName nDst' "addr2") (tAddr pp)+                let vPtr        =  Var (bumpName nDst' "ptr")   (tPtr tDst') -         -- 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+                labelFail       <- newUniqueLabel "peek-bounds"+                labelOk         <- newUniqueLabel "peek-ok" -                convBodyM context kenv tenv mdsup blocks label instrs -                        (C.XLet a (C.LLet b x1) x2)+                let blockEntry  = Block label+                                $ instrs +                                >< (Seq.fromList $ map annotNil+                                [ ICmp      vTest (ICond ICondUlt) xOffset' xLength'+                                , IBranchIf (XVar vTest) labelOk labelFail ]) -         -- 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+                let blockFail   = Block labelFail+                                $ Seq.fromList $ map annotNil+                                [ case ectx of+                                   ExpTop{}            -> INop+                                   ExpNest _   vDst' _ -> ISet vDst' (XUndef (typeOfVar vDst'))+                                   ExpAssign _ vDst'   -> ISet vDst' (XUndef (typeOfVar vDst')) -                -- Assign result of case to this variable.-                let n'    = A.sanitizeName n-                let vCont = Var (NameLocal n') t'+                                , ICall Nothing CallTypeStd Nothing +                                        TVoid (NameGlobal "abort") [] [] -                -- Label to jump to continue evaluating 'x1'-                lCont   <- newUniqueLabel "cont"+                                , IUnreachable] -                let context'    = BodyNest vCont lCont-                blocksCase      <- convCaseM context' pp kenv tenv mdsup -                                        label instrs xScrut alts+                let instrsCont  = Seq.fromList $ map annotNil+                                [ IConv     vAddr1 ConvPtrtoint xPtr'+                                , IOp       vAddr2 OpAdd (XVar vAddr1) xOffset'+                                , IConv     vPtr   ConvInttoptr (XVar vAddr2)+                                , ILoad     vDst   (XVar vPtr)] -                let tenv'       = Env.extend b tenv-                convBodyM context kenv tenv' mdsup-                        (blocks >< blocksCase) -                        lCont-                        Seq.empty-                        x2+                convertBody ctx' ectx +                        (blocks |> blockEntry |> blockFail) +                        labelOk instrsCont 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+         -- Write to a pointer, with integrated bounds check.+         A.XLet (A.LLet _ x1) x2+          | Just (p, as)                         <- takeXPrimApps x1+          , A.PrimStore A.PrimStorePokeBounded   <- p+          , A.RType{} : A.RType tVal : args      <- as+          , Just [mPtr, mOffset, mLength, mVal]  <- atomsR args+          -> do+                tVal'           <- convertType pp kenv tVal+                xPtr'           <- mPtr+                xOffset'        <- mOffset+                xLength'        <- mLength+                xVal'           <- mVal +                vTest           <- newUniqueNamedVar "test"  (TInt  1)+                vAddr1          <- newUniqueNamedVar "addr1" (tAddr pp)+                vAddr2          <- newUniqueNamedVar "addr2" (tAddr pp)+                vPtr            <- newUniqueNamedVar "ptr"   (tPtr  tVal') -         -- Letregions -------------------------------------         C.XLet _ (C.LPrivate b _mt _) x2-          -> do let kenv' = Env.extends b kenv-                convBodyM context kenv' tenv mdsup blocks label instrs x2+                labelFail       <- newUniqueLabel "poke-bounds"+                labelOk         <- newUniqueLabel "poke-ok" -         -- Case -------------------------------------------         C.XCase _ xScrut alts-          -> do blocks' <- convCaseM context pp kenv tenv mdsup -                                label instrs xScrut alts+                let blockEntry  = Block label+                                $ instrs +                                >< (Seq.fromList $ map annotNil+                                [ ICmp      vTest (ICond ICondUlt) xOffset' xLength'+                                , IBranchIf (XVar vTest) labelOk labelFail ]) -                return  $ blocks >< blocks'+                let blockFail   = Block labelFail+                                $ Seq.fromList $ map annotNil+                                [ case ectx of+                                   ExpTop{}            -> INop+                                   ExpNest _   vDst' _ -> ISet vDst' (XUndef (typeOfVar vDst'))+                                   ExpAssign _ vDst'   -> ISet vDst' (XUndef (typeOfVar vDst')) -        -- Cast --------------------------------------------         C.XCast _ _ x-          -> convBodyM context kenv tenv mdsup blocks label instrs x+                                , ICall Nothing CallTypeStd Nothing +                                        TVoid (NameGlobal "abort") [] [] -         _ -          | 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'))))+                                , IUnreachable] -          |  otherwise-          -> die $   renderIndent-                 $   text "Invalid body statement " -                 <$> ppr xx- +                let instrsCont  = Seq.fromList $ map annotNil+                                [ IConv     vAddr1 ConvPtrtoint xPtr'+                                , IOp       vAddr2 OpAdd (XVar vAddr1) xOffset'+                                , IConv     vPtr   ConvInttoptr (XVar vAddr2)+                                , IStore    (XVar vPtr)  xVal' ] --- 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        +                convertBody ctx ectx+                        (blocks |> blockEntry |> blockFail) +                        labelOk instrsCont x2 -        -- | Conversion in a context that expects a value.-        --   We evaluate the expression and assign the result to this variable.-        | ExpAssign Var-        deriving Show +         -- A let-bound expression without a name, of the void type.+         A.XLet (A.LLet (C.BNone t) x1) x2+          | isVoidT t+          -> do instrs' <- convertSimple ctx ectx x1+                convertBody ctx ectx blocks label+                        (instrs >< instrs') x2 --- | Take any assignable variable from an `ExpContext`.-varOfExpContext :: ExpContext -> Maybe Var-varOfExpContext xc- = case xc of-        ExpTop          -> Nothing-        ExpAssign var   -> Just var +         -- A let-bound expression without a name, of some non-void type.+         --   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.+         A.XLet (A.LLet (C.BNone t) x1) x2+          | not $ isVoidT t+          -> do n       <- newUnique+                let b   = C.BName (A.NameVar ("_d" ++ show n)) t --- | 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)+                convertBody ctx ectx blocks label instrs +                        (A.XLet (A.LLet b x1) x2) -convExpM context pp kenv tenv mdsup xx- = do   mm      <- gets llvmStateModule -        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))+         -- Variable assigment from a case-expression.+         A.XLet (A.LLet (C.BName nm t) +                        (A.XCase xScrut alts)) +                  x2+          -> do +                -- Bind the Salt name, allocating a new LLVM variable for it.+                --   The alternatives assign their final result to this variable.+                (ctx', vCont) <- bindLocalV ctx nm t  -                A.NameLitWord w bits-                 -> return $ Seq.singleton $ annotNil-                           $ ISet vDst (XLit (LitInt (TInt $ fromIntegral bits) w))+                -- Label to jump to continue evaluating 'x1'+                lCont         <- newUniqueLabel "cont" -                _ -> die "Invalid literal"+                -- Convert the alternatives.+                --   As the let-binding is non-recursive, the alternatives are+                --   converted in the original context, without the let-bound+                --   variable (ctx).+                let ectx'   =  ExpNest ectx vCont lCont+                blocksCase  <- convertCase ctx ectx' label instrs xScrut alts -         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+                -- Convert the body of the let-expression.+                --   This is done in the new context, with the let-bound variable.+                convertBody ctx' ectx+                        (blocks >< blocksCase) +                        lCont Seq.empty x2 -          -- Call to top-level super.-          | Just (xFun@(C.XVar _ u), xsArgs) <- takeXApps xx-          , Just (Var nFun _)                <- takeGlobalV pp mm 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+         -- Variable assignment from an instantiated super name.+         -- We can't generate LLVM code for these bindings directly, so they are+         -- stashed in the context until we find a conversion that needs them.+         -- See [Note: Binding top-level supers]+         A.XLet (A.LLet (C.BName nBind _) x1) x2+          | (xF, asArgs)                <- splitXApps x1+          , A.XVar (C.UName nSuper)     <- xF+          , tsArgs  <- [t | A.RType t   <- asArgs]+          , length tsArgs > 0+          , length asArgs == length tsArgs+          ,   Set.member nSuper (contextSupers  ctx)+           || Set.member nSuper (contextImports ctx)+          -> do let ctx'   = ctx { contextSuperBinds +                                    = Map.insert nBind (nSuper, tsArgs)+                                        (contextSuperBinds ctx) }+                convertBody ctx' ectx blocks label instrs x2  -         _ -> die $ "Invalid expression " ++ show xx +         -- Variable assignment from some other expression.+         A.XLet (A.LLet (C.BName nm t) x1) x2+          -> do +                -- Bind the Salt name, allocating a new LLVM variable name for it.+                (ctx', vDst) <- bindLocalV ctx nm t --- 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)+                -- Convert the bound expression.+                --   As the let-binding is non-recursive, the bound expression+                --   is converted in the original context, without the let-bound+                --   variable (ctx).+                instrs'  <- convertSimple ctx (ExpAssign ectx vDst) x1+                +                -- Convert the body of the let-expression.+                --   This is done in the new context, with the let-bound variable.+                convertBody ctx' ectx blocks label (instrs >< instrs') x2 -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"+         -- Letregions ------------------------------------+         A.XLet (A.LPrivate bsType _mt _) x2+          -> do let ctx'  = extendsKindEnv bsType ctx+                convertBody ctx' ectx blocks label instrs x2  --- 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)+         -- Case ------------------------------------------+         A.XCase xScrut alts+          -> do blocks' <- convertCase ctx ectx label instrs xScrut alts+                return  $ blocks >< blocks'  --- 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)+         -- Cast -------------------------------------------+         A.XCast _ x+          -> convertBody ctx ectx blocks label instrs x +         _ +          | ExpNest _ vDst label' <- ectx+          -> do instrs'  <- convertSimple ctx (ExpAssign ectx vDst) xx+                return  $ blocks >< Seq.singleton (Block label +                                (instrs >< (instrs' |> (annotNil $ IBranch label')))) --- Alt ----------------------------------------------------------------------------------------------- | Holds the result of converting an alternative.-data AltResult-        = AltDefault        Label (Seq Block)-        | AltCase       Lit Label (Seq Block)+          |  otherwise+          -> throw $ ErrorInvalidExp xx+                   $ Just "Cannot use this as the body of a super."  --- | Convert a case alternative to LLVM.+-- Exp --------------------------------------------------------------------------------------------+-- | Convert a simple Core expression to LLVM instructions. -----   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.+--   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. -----   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+convertSimple+        :: Context -> ExpContext+        -> A.Exp+        -> ConvertM (Seq AnnotInstr) -        A.NameLitNat  i      -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i+convertSimple ctx ectx xx+ = let  pp      = contextPlatform ctx+        tenv    = contextTypeEnv  ctx+        kenv    = contextKindEnv  ctx+   in do   +        case xx of+         -- Atoms+         _ | ExpAssign _ vDst   <- ectx+           , Just mx            <- mconvAtom ctx xx+           -> do x' <- mx+                 return $ Seq.singleton $ annotNil +                        $ ISet vDst x' -        A.NameLitInt  i      -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i+         -- Primitive operators.+         A.XApp{}+          | Just (p, args) <- takeXPrimApps xx+          , mDst        <- takeNonVoidVarOfContext ectx+          , Just go     <- foldl (<|>) empty+                                [ convPrimCall  ctx mDst p args+                                , convPrimArith ctx mDst p args+                                , convPrimCast  ctx mDst p args+                                , convPrimStore ctx mDst p args ]+          -> go -        A.NameLitWord i bits -         | elem bits [8, 16, 32, 64]-         -> Just $ LitInt (TInt $ fromIntegral bits) i+          -- Call to top-level super.+          | (xFun@(A.XVar u), xsArgs) <- splitXApps xx+          , Just tSuper         <- Env.lookup u tenv+          , Just msArgs_value   <- sequence $ map (mconvArg ctx) $ eraseTypeWitArgs xsArgs+          , Just mFun           <- takeGlobalV ctx xFun+          -> do +                Var nFun _      <- mFun+                xsArgs_value'   <- sequence $ msArgs_value+                (_, tResult)    <- convertSuperType pp kenv tSuper+                let mv          = case tResult of+                                        TVoid   -> Nothing+                                        _       -> takeNonVoidVarOfContext ectx -        A.NameLitTag  i      -> Just $ LitInt (TInt (8 * platformTagBytes pp))  i+                return  $ Seq.singleton $ annotNil+                        $ ICall  mv CallTypeStd Nothing+                                 tResult nFun xsArgs_value' []+         -- Casts+         A.XCast _ x+           -> convertSimple ctx ectx x -        _                    -> Nothing+         _ -> throw $ ErrorInvalidExp xx+                    $ Just "Was expecting a variable, primitive, or super application."  --- | Take the blocks from an `AltResult`.-altResultBlocks :: AltResult -> Seq Block-altResultBlocks aa- = case aa of-        AltDefault _ blocks     -> blocks-        AltCase _ _  blocks     -> blocks+---------------------------------------------------------------------------------------------------+-- | Erase type and witness arge Slurp out only the values from a list of+--   function arguments.+eraseTypeWitArgs :: [A.Arg] -> [A.Arg]+eraseTypeWitArgs []       = []+eraseTypeWitArgs (x:xs)+ = case x of+        A.RType{}       -> eraseTypeWitArgs xs+        A.RWitness{}    -> eraseTypeWitArgs xs+        _               -> x : eraseTypeWitArgs xs  --- | Take the `Lit` and `Label` from an `AltResult`-takeAltCase :: AltResult -> Maybe (Lit, Label)-takeAltCase (AltCase lit label _)       = Just (lit, label)-takeAltCase _                           = Nothing-+-- | Append the given string to a name.+bumpName :: Name -> String -> Name+bumpName nn s+ = case nn of+        NameLocal str   -> NameLocal  (str ++ "." ++ s)+        NameGlobal str  -> NameGlobal (str ++ "." ++ s)

@@ -0,0 +1,283 @@++module DDC.Core.Llvm.Convert.Exp.Atom+        ( mconvArg+        , mconvAtom++        , bindLocalV+        , bindLocalA,   bindLocalAs+        , takeLocalV+        , takeGlobalV)+where+import DDC.Llvm.Syntax+import DDC.Core.Llvm.Convert.Type+import DDC.Core.Llvm.Convert.Context+import DDC.Core.Llvm.Convert.Base+import DDC.Core.Salt.Platform+import DDC.Control.Monad.Check+import DDC.Base.Pretty+import Control.Monad+import Data.Maybe+import qualified DDC.Type.Env                   as Env+import qualified DDC.Core.Salt                  as A+import qualified DDC.Core.Salt.Convert          as A+import qualified DDC.Core.Module                as C+import qualified DDC.Core.Exp                   as C+import qualified Data.Map                       as Map+import qualified Data.List                      as List+++-- Arguments ------------------------------------------------------------------+-- | Convert a function argument expression+--   yielding Nothing if this is a `Witness` or `Type`.+mconvArg :: Context -> A.Arg -> Maybe (ConvertM Exp)+mconvArg ctx aa+ = case aa of+        A.RWitness _    -> Nothing+        A.RExp x        -> mconvAtom ctx x+        A.RType _       -> Nothing+++-- Atoms ----------------------------------------------------------------------+-- | Convert an atomic expression to LLVM, +--   or `Nothing` if this is not one of those.+--+--   If the expression is an atom but is mistyped or malformed then running+--   the returned computation will throw an exception in the ConvertM monad.+--+--   Converted atoms can be used directly as arguments to LLVM instructions.+--+mconvAtom :: Context -> A.Exp -> Maybe (ConvertM Exp)+mconvAtom ctx xx+ = let  pp      = contextPlatform ctx+        kenv    = contextKindEnv  ctx+   in case xx of++        -- Global names+        A.XVar (C.UName _)+         |  Just mv     <- takeGlobalV ctx xx+         -> Just $ do  +                var     <- mv+                return  $ XVar var++        -- Local names+        A.XVar (C.UName _)+         |  Just mv     <- takeLocalV ctx xx+         -> Just $ do+                var     <- mv+                return  $ XVar var++        -- Literal unit values are represented as a null pointer.+        A.XCon C.DaConUnit+         -> Just $ return $ XLit (LitNull (TPointer (tObj pp)))++        -- Primitive unboxed literals.+        A.XCon dc+         | C.DaConPrim (A.NamePrimLit lit) t <- dc+         -> do case lit of+                -- Literal booleans.+                A.PrimLitBool b+                 -> let i | b           = 1+                          | otherwise   = 0+                    in Just $ do+                        t' <- convertType pp kenv t+                        return $ XLit (LitInt t' i)++                -- Literal natural numbers of some width.+                A.PrimLitNat nat   +                 -> Just $ do+                        t' <- convertType pp kenv t+                        return $ XLit (LitInt t' nat)++                -- Literal integers of some width.+                A.PrimLitInt  val+                 -> Just $ do+                        t' <- convertType pp kenv t+                        return $ XLit (LitInt t' val)++                -- Literal size value.+                A.PrimLitSize val+                 -> Just $ do+                        t' <- convertType pp kenv t+                        return $ XLit (LitInt t' val)++                -- Literal binary word of some width.+                A.PrimLitWord val _+                 -> Just $ do+                        t' <- convertType pp kenv t+                        return $ XLit (LitInt t' val)++                -- Literal floating point value of some width.+                A.PrimLitFloat val _+                 -> Just $ do+                        t' <- convertType pp kenv t+                        return $ XLit (LitFloat t' val)++                -- A text literal.+                A.PrimLitTextLit tx+                 -> Just $ do+                        -- Add literal text constant to the constants map for+                        -- the current module. These constants will be+                        -- allocated into static memory, and reachable by the+                        -- returned name.+                        var     <- addConstant ctx $ makeLitString tx+                        let w   = 8 * platformAddrBytes pp+                        +                        return  $ XGet (TPointer (TInt 8))+                                       (XVar var) +                                       [ XLit (LitInt (TInt w) 0)+                                       , XLit (LitInt (TInt w) 0) ]++                -- Literal constructor tag.+                A.PrimLitTag  tag   +                 -> Just $ do+                        t' <- convertType pp kenv t+                        return $ XLit (LitInt t' tag)++                _ -> Nothing++        _ -> Nothing+++-- Local Variables ------------------------------------------------------------+-- | Add a variable and its type to the context,+--   producing the corresponding LLVM variable name.+---+--   We need to sanitize the incoming name because it may include symbols+--   that are not valid for LLVM names. We also need to uniquify them, +--   to avoid name clashes as the the variables in a single LLVM function+--   are all bound at the same level.+--+bindLocalS :: Context -> String -> A.Type -> ConvertM (Context, Var)+bindLocalS ctx str t+ = do   t'       <- convertType (contextPlatform ctx) (contextKindEnv ctx) t+        let str'  = A.sanitizeName str+        v        <- newUniqueNamedVar str' t'+        let name  = A.NameVar str+        let ctx'  = extendTypeEnv (C.BName name t) ctx+        let ctx'' = ctx' { contextNames = Map.insert name v (contextNames ctx') }+        return (ctx'', v)+++-- | Add a variable and its type to the context,+--   producing the corresponding LLVM variable name.+---+--   We need to sanitize the incoming name because it may include symbols+--   that are not valid for LLVM names. We also need to uniquify them, +--   to avoid name clashes as the the variables in a single LLVM function+--   are all bound at the same level.+--+bindLocalV :: Context -> A.Name -> C.Type A.Name -> ConvertM (Context, Var)+bindLocalV ctx (A.NameVar str) t+ = do   bindLocalS ctx str t++bindLocalV _ _ _+ = error "ddc-core-llvm.bindLocalV: not a regular name."+++-- | Like `bindLocalV`, but take the binder directly.+bindLocalB  :: Context -> A.Bind -> ConvertM (Context, Var)+bindLocalB ctx b + = case b of+        C.BName nm t    -> bindLocalV ctx nm t+        C.BNone t       -> bindLocalV ctx (A.NameVar "_arg") t+        C.BAnon _       +         -> error "ddc-core-llvm.bindLocalB: can't convert anonymous binders."+++-- | Add the binder for a thing to the context.+bindLocalA  :: Context -> A.Abs -> ConvertM (Context, Maybe Var)+bindLocalA ctx aa+ = case aa of+        A.ALAM b+         -> return ( ctx { contextKindEnv = Env.extend b $ contextKindEnv ctx }+                   , Nothing)++        A.ALam b+         -> do  (ctx', v')      <- bindLocalB ctx b+                return (ctx', Just v')+++-- | Add the binders for some things to the context.+bindLocalAs :: Context -> [A.Abs] -> ConvertM (Context, [Var])+bindLocalAs ctx []      = return (ctx, [])+bindLocalAs ctx (a : as)+ = do   (ctx',  mv)     <- bindLocalA  ctx a+        (ctx'', vs)     <- bindLocalAs ctx' as+        return (ctx'', maybeToList mv ++ vs)+++-- | Take a variable from an expression as a local var, if any.+takeLocalV  +        :: Context -> A.Exp+        -> Maybe (ConvertM Var)++takeLocalV ctx xx+ = case xx of+        A.XVar (C.UName nm)+         |     Just v     <- Map.lookup nm (contextNames ctx)+         ->    Just (return v)+        _ ->   Nothing+++-- Global Variables / Names ---------------------------------------------------+-- | Take a variable from an expression as a global var, if any.+---+--   The seaNameOfSuper function sanitizes these, so we can use+--   them as valid LLVM names.+--+takeGlobalV  +        :: Context -> A.Exp+        -> Maybe (ConvertM Var)++takeGlobalV ctx xx+ = let  pp      = contextPlatform    ctx+        mm      = contextModule      ctx+        kenv    = contextKindEnvTop  ctx+        tenv    = contextTypeEnvTop  ctx++   in case xx of+        A.XVar u@(C.UName nSuper)+         | Just t   <- Env.lookup u tenv+         -> Just $ do+                let mImport  = lookup nSuper (C.moduleImportValues mm)+                let mExport  = lookup nSuper (C.moduleExportValues mm)++                -- Convert local name to sanitized LLVM name.+                let Just str = liftM renderPlain +                             $ A.seaNameOfSuper mImport mExport nSuper++                t'      <- convertType pp kenv t+                return  $ Var (NameGlobal str) t'++        _ ->    Nothing+++-------------------------------------------------------------------------------+-- | Add a static constant to the map, +--   assigning a new variable to refer to it.+addConstant :: Context -> Lit -> ConvertM Var+addConstant ctx lit+ = do   +        -- This name is going into the global scope,+        -- so prepend the module name to uniquify it.+        let C.ModuleName parts +                        = C.moduleName $ contextModule ctx+        let mname       = List.intercalate "." parts++        -- Make a new variable to name the literal constant.+        (Var (NameLocal sLit) tLit) +                <- newUniqueNamedVar mname (typeOfLit lit)++        let nLit =  NameGlobal sLit+        let vLit =  Var nLit tLit++        s        <- get+        put     $ s { llvmConstants = Map.insert vLit lit (llvmConstants s)}++        -- Although the constant itself has type tLit, when we refer+        -- to a global name in the body of the code the reference is +        -- has pointer type.+        let vRef = Var nLit (TPointer tLit)+        return vRef++

@@ -0,0 +1,206 @@++module DDC.Core.Llvm.Convert.Exp.Case+        (convertCase)+where+import DDC.Core.Llvm.Convert.Exp.Atom+import DDC.Core.Llvm.Convert.Context+import DDC.Core.Llvm.Convert.Base+import DDC.Llvm.Syntax+import DDC.Core.Salt.Platform+import DDC.Core.Exp.Annot.Compounds+import DDC.Data.ListUtils+import Control.Monad+import Data.Maybe+import Data.Sequence                    (Seq, (<|), (|>), (><))+import qualified DDC.Core.Salt          as A+import qualified DDC.Core.Exp           as C+import qualified Data.Sequence          as Seq+++-- Case -------------------------------------------------------------------------------------------+convertCase+        :: Context              -- ^ Context of the conversion.+        -> ExpContext           -- ^ Expression context.+        -> Label                -- ^ Label of current block+        -> Seq AnnotInstr       -- ^ Instructions to prepend to initial block.+        -> A.Exp                -- ^ Scrutinee of case expression.+        -> [A.Alt]              -- ^ Alternatives of case expression.+        -> ConvertM (Seq Block)++convertCase ctx ectx label instrs xScrut alts + | Just mVar    <- takeLocalV ctx xScrut+ = do+        vScrut' <- mVar++        -- 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) +         <- convertAlts ctx ectx alts++        -- 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)++        -- Get the alternatives before the default one.+        -- This will fail if there are no alternatives at all.+        altsTable       +         <- case takeInit alts' of+                Nothing -> throw $ ErrorInvalidExp (A.XCase xScrut alts) Nothing+                Just as -> return as++        -- 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)++ | otherwise + = throw $ ErrorInvalidExp (A.XCase xScrut alts) Nothing+++-- Alts -------------------------------------------------------------------------------------------+-- | Convert some case alternatives to LLVM.+convertAlts+        :: Context -> ExpContext+        -> [A.Alt]+        -> ConvertM ([AltResult], Seq Block)++-- Alternatives are at top level.+convertAlts ctx ectx@ExpTop{} alts+ = do   +        alts'   <- mapM (convertAlt ctx ectx) 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.+convertAlts ctx (ExpNest ectx vDst lCont) alts+ = do+        -- 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" (typeOfVar vDst)+                        alt'    <- convertAlt ctx (ExpNest ectx vDst' lJoin) alt+                        lAlt    <- return (altResultLabel alt')+                        return ((XVar vDst', lAlt), alt'))+                $  alts++        -- A block to join the result from each alternative.+        let blockJoin   +                = Block lJoin+                $ Seq.fromList $ map annotNil+                [ IPhi vDst vDstAlts+                , IBranch lCont ]++        return (alts', Seq.singleton blockJoin)++-- Cannot convert alternative in this context.+convertAlts _ ExpAssign{} alts+ = throw $ ErrorInvalidAlt alts+         $ Just "Cannot convert alternative in this context."+++-- Alt --------------------------------------------------------------------------------------------+-- | Convert a case alternative to LLVM.+--+--   This only works for zero-arity constructors.+--   The client should extract the fields of algebraic data objects manually.+convertAlt+        :: Context -> ExpContext+        -> A.Alt+        -> ConvertM AltResult++convertAlt ctx ectx aa+ = let  pp              = contextPlatform ctx+        convBodyM       = contextConvertBody ctx+   in case aa of+        A.AAlt A.PDefault x+         -> do  label   <- newUniqueLabel "default"+                blocks  <- convBodyM ctx ectx Seq.empty label Seq.empty x+                return  $  AltDefault label blocks++        A.AAlt (A.PData C.DaConUnit []) x+         -> do  label   <- newUniqueLabel "alt"+                blocks  <- convBodyM ctx ectx Seq.empty label Seq.empty x+                return  $  AltDefault label blocks++        A.AAlt (A.PData dc []) x+         | Just n       <- takeNameOfDaCon dc+         , Just lit     <- convPatName pp n+         -> do  label   <- newUniqueLabel "alt"+                blocks  <- convBodyM ctx ectx Seq.empty label Seq.empty x+                return  $  AltCase lit label blocks++        _ -> throw $ ErrorInvalidAlt [aa] Nothing+++-- | 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 (A.NamePrimLit lit)+ = case lit of+        A.PrimLitBool True+         -> Just $ LitInt (TInt 1) 1++        A.PrimLitBool False+         -> Just $ LitInt (TInt 1) 0++        A.PrimLitNat  i+         -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i++        A.PrimLitInt  i+         -> Just $ LitInt (TInt (8 * platformAddrBytes pp)) i++        A.PrimLitWord i bits +         | elem bits [8, 16, 32, 64]+         -> Just $ LitInt (TInt $ fromIntegral bits) i++        A.PrimLitTag  i+         -> Just $ LitInt (TInt (8 * platformTagBytes pp))  i++        _ -> Nothing++convPatName _ _ + = Nothing+++-- | Take the label from an `AltResult`.+altResultLabel :: AltResult -> Label+altResultLabel aa+ = case aa of+        AltDefault label _      -> label+        AltCase  _ label _      -> label+++-- | 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 ac+ = case ac of+        AltCase lit label _     -> Just (lit, label)+        _                       -> Nothing+

@@ -0,0 +1,157 @@++module DDC.Core.Llvm.Convert.Exp.PrimArith+        (convPrimArith)+where+import DDC.Llvm.Syntax+import DDC.Core.Llvm.Convert.Exp.Atom+import DDC.Core.Llvm.Convert.Context+import DDC.Core.Llvm.Convert.Type+import DDC.Core.Llvm.Convert.Base+import Data.Sequence                    (Seq)+import qualified DDC.Core.Exp           as C+import qualified DDC.Core.Salt          as A+import qualified Data.Sequence          as Seq+++-- | Convert a primitive call to LLVM,+--   or Nothing if this doesn't look like such an operation.+convPrimArith+        :: Context              -- ^ Context of the conversion.+        -> Maybe Var            -- ^ Assign result to this var.+        -> A.PrimOp             -- ^ Primitive to call.+        -> [A.Arg]              -- ^ Arguments to primitive.+        -> Maybe (ConvertM (Seq AnnotInstr))++convPrimArith ctx mdst p xs+ = let  pp              = contextPlatform ctx+        kenv            = contextKindEnv  ctx+   in case p of+        -- Unary operators ------------+        A.PrimArith op+         | A.RType t : args     <- xs+         , Just dst             <- mdst+         , Just [mx1]           <- sequence $ map (mconvArg ctx) args+         -> Just $ do+                x1'     <- mx1+                t'      <- convertType pp kenv t+                let result+                     | A.PrimArithNeg <- op+                     , isIntegralT t+                     = return $ IOp dst OpSub (XLit $ LitInt t' 0) x1'++                     | A.PrimArithNeg <- op+                     , isFloatingT t+                     = return $ IOp dst OpSub (XLit $ LitFloat t' 0) x1'++                     -- Cannot use primop at this type.+                     | otherwise+                     = throw  $ ErrorInvalidArith op t++                instr  <- result+                return $ Seq.singleton (annotNil instr)++        -- Binary operators -----------+        A.PrimArith op+         | A.RType t : args   <- xs+         , Just dst             <- mdst+         , Just [mx1, mx2]      <- sequence $ map (mconvArg ctx) args+         -> Just $ do+                x1'     <- mx1+                x2'     <- mx2+                let result+                     | Just op'     <- convPrimArith2 op t+                     = return $ IOp dst op' x1' x2'++                     | Just icond'  <- convPrimICond op t+                     = return $ ICmp dst (ICond icond') x1' x2'++                     | Just fcond'  <- convPrimFCond op t+                     = return $ ICmp dst (FCond fcond') x1' x2'++                     -- Cannot use primop at this type.+                     | otherwise+                     = throw  $ ErrorInvalidArith op t++                instr  <- result+                return $ Seq.singleton (annotNil instr)++        -- This doesn't look like an arithmetic primop.+        _ -> Nothing+++-- | Convert a binary primop from Core Sea to LLVM form.+convPrimArith2 :: A.PrimArith -> C.Type A.Name -> Maybe Op+convPrimArith2 op t+ = case op of+        A.PrimArithAdd+         | isIntegralT t                -> Just OpAdd+         | isFloatingT t                -> Just OpFAdd++        A.PrimArithSub+         | isIntegralT t                -> Just OpSub+         | isFloatingT t                -> Just OpFSub++        A.PrimArithMul+         | isIntegralT t                -> Just OpMul+         | isFloatingT t                -> Just OpFMul++        A.PrimArithDiv+         | isIntegralT t, isUnsignedT t -> Just OpUDiv+         | isIntegralT t, isSignedT t   -> Just OpSDiv+         | isFloatingT t                -> Just OpFDiv++        A.PrimArithRem+         | isIntegralT t, isUnsignedT t -> Just OpURem+         | isIntegralT t, isSignedT t   -> Just OpSRem+         | isFloatingT t                -> Just OpFRem++        A.PrimArithShl+         | isIntegralT t                -> Just OpShl++        A.PrimArithShr+         | isIntegralT t, isUnsignedT t -> Just OpLShr+         | isIntegralT t, isSignedT t   -> Just OpAShr++        A.PrimArithBAnd+         | isIntegralT t                -> Just OpAnd++        A.PrimArithBOr+         | isIntegralT t                -> Just OpOr++        A.PrimArithBXOr+         | isIntegralT t                -> Just OpXor++        _                               -> Nothing+++-- | Convert an integer comparison from Core Sea to LLVM form.+convPrimICond :: A.PrimArith -> C.Type A.Name -> Maybe ICond+convPrimICond op t+ | isIntegralT t+ = case op of+        A.PrimArithEq                   -> Just ICondEq+        A.PrimArithNeq                  -> Just ICondNe+        A.PrimArithGt                   -> Just ICondUgt+        A.PrimArithGe                   -> Just ICondUge+        A.PrimArithLt                   -> Just ICondUlt+        A.PrimArithLe                   -> Just ICondUle+        _                               -> Nothing++ | otherwise = Nothing+++-- | Convert a floating point comparison from Core Sea to LLVM form.+convPrimFCond :: A.PrimArith -> C.Type A.Name -> Maybe FCond+convPrimFCond op t+ | isIntegralT t+ = case op of+        A.PrimArithEq                   -> Just FCondOeq+        A.PrimArithNeq                  -> Just FCondOne+        A.PrimArithGt                   -> Just FCondOgt+        A.PrimArithGe                   -> Just FCondOge+        A.PrimArithLt                   -> Just FCondOlt+        A.PrimArithLe                   -> Just FCondOle+        _                               -> Nothing++ | otherwise = Nothing+

@@ -0,0 +1,56 @@++module DDC.Core.Llvm.Convert.Exp.PrimCall+        (convPrimCall)+where+import DDC.Llvm.Syntax+import DDC.Core.Llvm.Convert.Exp.Atom+import DDC.Core.Llvm.Convert.Type+import DDC.Core.Llvm.Convert.Context+import DDC.Core.Llvm.Convert.Base+import Data.Sequence            (Seq)+import qualified DDC.Core.Salt          as A+import qualified Data.Sequence          as Seq+++-- | Convert a primitive store operation to LLVM.+convPrimCall+        :: Context              -- ^ Context of the conversion.+        -> Maybe Var            -- ^ Assign result to this var.+        -> A.PrimOp             -- ^ Prim to call.+        -> [A.Arg]              -- ^ Arguments to prim.+        -> Maybe (ConvertM (Seq AnnotInstr))++convPrimCall ctx mDst p xs+ = let  pp              = contextPlatform ctx+   in case p of+        A.PrimCall (A.PrimCallStd arity)+         | Just (mFun : msArgs) <- sequence $ map (mconvArg ctx) xs+         -> Just $ do+                xFun'   <- mFun+                xsArgs' <- sequence msArgs++                vFun@(Var nFun _) +                        <- newUniqueNamedVar "fun" +                        $  TPointer $ tFunction (replicate arity (tAddr pp)) (tAddr pp)++                return  $ Seq.fromList $ map annotNil+                        [ IConv vFun (ConvInttoptr) xFun'+                        , ICall mDst CallTypeStd Nothing+                                      (tAddr pp) nFun xsArgs' []]++        _ -> Nothing+++-- Build the type of a function with the given arguments and result type.+tFunction :: [Type] -> Type -> Type+tFunction tsArgs tResult+        = TFunction+        $ FunctionDecl+        { declName              = "anon"+        , declLinkage           = External+        , declCallConv          = CC_Ccc+        , declReturnType        = tResult+        , declParamListType     = FixedArgs+        , declParams            = [ Param t [] | t <- tsArgs ]+        , declAlign             = AlignNone }+

@@ -0,0 +1,176 @@++module DDC.Core.Llvm.Convert.Exp.PrimCast+        (convPrimCast)+where+import DDC.Llvm.Syntax+import DDC.Core.Llvm.Convert.Exp.Atom+import DDC.Core.Llvm.Convert.Type+import DDC.Core.Llvm.Convert.Context+import DDC.Core.Llvm.Convert.Base+import DDC.Core.Salt.Platform+import Data.Sequence                    (Seq)+import qualified DDC.Core.Exp           as C+import qualified DDC.Core.Salt          as A+import qualified Data.Sequence          as Seq+import qualified Data.Map               as Map+++-------------------------------------------------------------------------------+-- | Convert a primitive call to LLVM,+--   or Nothing if this doesn't look like such an operation.+convPrimCast+        :: Context              -- ^ Context of the conversion.+        -> Maybe Var            -- ^ Assign result to this var.+        -> A.PrimOp             -- ^ Primitive to call.+        -> [A.Arg]              -- ^ Arguments to primitive.+        -> Maybe (ConvertM (Seq AnnotInstr))++convPrimCast ctx mdst p as+ = case p of+        A.PrimCast A.PrimCastConvert+         | [A.RType tDst, A.RType tSrc, xSrc] <- as+         , Just vDst            <- mdst+         -> Just $ do+                instr   <- convPrimConvert ctx tDst vDst tSrc xSrc+                return  $  Seq.singleton (annotNil instr)++        A.PrimCast A.PrimCastPromote+         | [A.RType tDst, A.RType tSrc, xSrc] <- as+         , Just vDst            <- mdst+         , Just mSrc            <- mconvArg ctx xSrc+         -> Just $ do+                xSrc'   <- mSrc+                instr   <- convPrimPromote ctx tDst vDst tSrc xSrc'+                return  $  Seq.singleton (annotNil instr) ++        A.PrimCast A.PrimCastTruncate+         | [A.RType tDst, A.RType tSrc, xSrc] <- as+         , Just vDst            <- mdst+         , Just mSrc            <- mconvArg ctx xSrc+         -> Just $ do+                xSrc'   <- mSrc+                instr   <- convPrimTruncate ctx tDst vDst tSrc xSrc'+                return  $  Seq.singleton (annotNil instr)++        _ -> Nothing+++-------------------------------------------------------------------------------+-- | Convert a primitive conversion operator to LLVM,+--   or `Nothing` for an invalid conversion.+convPrimConvert+        :: Context+        -> C.Type A.Name -> Var+        -> C.Type A.Name -> A.Arg+        -> ConvertM Instr++convPrimConvert ctx tDst vDst tSrc aSrc+ | pp     <- contextPlatform ctx+ , kenv   <- contextKindEnv  ctx+ = do+        tSrc'   <- convertType pp kenv tSrc+        tDst'   <- convertType pp kenv tDst++        case tSrc' of++         -- Produce the code pointer for a top-level super.+         TPointer TFunction{}++          -- Argument is the name of the super itself.+          | tDst'      == TInt (8 * platformAddrBytes pp)+          , Just mSrc               <- mconvArg ctx aSrc+          -> do xSrc' <- mSrc+                return $ IConv vDst ConvPtrtoint xSrc'++          -- Argument is a variable that has been bound to an application of+          -- a super variable to some type arguments.+          | tDst'      == TInt (8 * platformAddrBytes pp)+          , A.RExp (A.XVar (C.UName nVar))   <- aSrc+          , Just (nSuper, _tsArgs)  <- Map.lookup nVar (contextSuperBinds ctx)+          , Just mSrc               <- mconvArg ctx (A.RExp (A.XVar (C.UName nSuper)))+          -> do xSrc' <- mSrc+                return $ IConv vDst ConvPtrtoint xSrc'++         -- Conversion is not valid on this platform.+         _ -> throw $ ErrorInvalidConversion tSrc tDst+++-------------------------------------------------------------------------------+-- | Convert a primitive promotion operator to LLVM,+--   or `Nothing` for an invalid promotion.+convPrimPromote+        :: Context+        -> C.Type A.Name -> Var+        -> C.Type A.Name -> Exp+        -> ConvertM Instr++convPrimPromote ctx tDst vDst tSrc xSrc+ = do+        let pp   =  contextPlatform ctx+        let kenv =  contextKindEnv  ctx++        tSrc'    <- convertType pp kenv tSrc+        tDst'    <- convertType pp kenv tDst++        case (tDst', tSrc') of+         (TInt bitsDst, TInt bitsSrc)++          -- Same sized integers+          | bitsDst == bitsSrc+          -> return $ ISet vDst xSrc++          -- Both Unsigned+          | isUnsignedT tSrc, isUnsignedT tDst+          , bitsDst > bitsSrc+          -> return $ IConv vDst ConvZext xSrc++          -- Both Signed+          | isSignedT tSrc,   isSignedT tDst+          , bitsDst > bitsSrc+          -> return $ IConv vDst ConvSext xSrc++          -- Unsigned to Signed+          | isUnsignedT tSrc, isSignedT   tDst+          , bitsDst > bitsSrc+          -> return $ IConv vDst ConvZext xSrc++         -- Promotion is not valid on this platform.+         _ -> throw $ ErrorInvalidPromotion tSrc tDst+++-------------------------------------------------------------------------------+-- | Convert a primitive truncation to LLVM,+--   or `Nothing` for an invalid truncation.+convPrimTruncate+        :: Context+        -> C.Type  A.Name -> Var+        -> C.Type  A.Name -> Exp+        -> ConvertM Instr++convPrimTruncate ctx tDst vDst tSrc xSrc+ = do+        let pp   = contextPlatform ctx+        let kenv = contextKindEnv  ctx++        tSrc' <- convertType pp kenv tSrc+        tDst' <- convertType pp kenv tDst++        case (tDst', tSrc') of+         (TInt bitsDst, TInt bitsSrc)+          -- Same sized integers+          | bitsDst == bitsSrc+          -> return $ ISet vDst xSrc++          -- Destination is smaller+          | bitsDst < bitsSrc+          -> return $ IConv vDst ConvTrunc xSrc++          -- Unsigned to Signed,+          --  destination is larger+          | bitsDst > bitsSrc+          , isUnsignedT tSrc,   isSignedT tDst+          -> return $ IConv vDst ConvZext xSrc++         -- Truncation is not valid on this platform.+         _ -> throw $ ErrorInvalidTruncation tSrc tDst+

@@ -0,0 +1,309 @@++module DDC.Core.Llvm.Convert.Exp.PrimStore+        (convPrimStore)+where+import DDC.Llvm.Syntax+import DDC.Core.Llvm.Convert.Exp.Atom+import DDC.Core.Llvm.Convert.Type+import DDC.Core.Llvm.Convert.Context+import DDC.Core.Llvm.Convert.Base+import DDC.Core.Llvm.Metadata.Tbaa+import DDC.Core.Llvm.Runtime+import DDC.Core.Salt.Platform+import DDC.Core.Exp.Generic.BindStruct  ()+import Data.Sequence                    (Seq)+import qualified DDC.Core.Salt          as A+import qualified Data.Sequence          as Seq+++-- | Convert a primitive store operation to LLVM, +--   or Nothing if this does not look like such an operation.+convPrimStore+        :: Context              -- ^ Context of the conversion.+        -> Maybe Var            -- ^ Assign result to this var.+        -> A.PrimOp             -- ^ Prim to call.+        -> [A.Arg]              -- ^ Arguments to prim.+        -> Maybe (ConvertM (Seq AnnotInstr))++convPrimStore ctx mdst p as+ = let  pp         = contextPlatform ctx+        mdsup      = contextMDSuper  ctx+        kenv       = contextKindEnv  ctx+        atom       = mconvAtom       ctx+        atomsR as' = sequence $ map (mconvArg ctx) as'++   in case p of++        -- Get the size in bytes of some primitive type.+        A.PrimStore A.PrimStoreSize+         | [A.RType t]  <- as+         , Just vDst    <- mdst+         -> Just $ do+                t'      <- convertType pp kenv t++                -- Bool# is only 1 bit long.+                -- Don't return a result for types that don't divide into 8 bits evenly.+                size    +                 <- case t' of+                        TPointer _           -> return $ platformAddrBytes pp+                        TInt bits+                         | bits `rem` 8 == 0 -> return $ bits `div` 8+                        _ -> throw $ ErrorInvalidSizeType t++                return  $ Seq.singleton+                        $ annotNil+                        $ ISet vDst (XLit (LitInt (tNat pp) size))+++        -- Get the log2 size in bytes of some primtive type.+        A.PrimStore A.PrimStoreSize2+         | [A.RType t]  <- as+         , Just vDst    <- mdst+         -> Just $ do+                t'      <- convertType pp kenv t++                -- Bool# is only 1 bit long.+                -- Don't return a result for types that don't divide into 8 bits evenly.+                size    +                 <- case t' of+                        TPointer _              -> return $ platformAddrBytes pp+                        TInt bits+                          |  bits `rem` 8 == 0  -> return $ bits `div` 8++                        _ -> throw $ ErrorInvalidSize2Type t++                let size2   +                        = truncate $ (log (fromIntegral size) / log 2 :: Double)++                return  $ Seq.singleton+                        $ annotNil+                        $ ISet vDst (XLit (LitInt (tNat pp) size2))+++        -- Create the initial heap.+        -- This is called once when the program starts.+        A.PrimStore A.PrimStoreCreate+         | Just [mBytes]    <- atomsR as+         -> Just $ do+                xBytes'     <- mBytes+                vAddr       <- newUniqueNamedVar "addr" (tAddr pp)+                vMax        <- newUniqueNamedVar "max"  (tAddr pp)+                let vTopPtr =  varGlobalHeapTop pp+                let vMaxPtr =  varGlobalHeapMax pp+                return  $ Seq.fromList+                        $ map annotNil+                        [ ICall (Just vAddr) CallTypeStd Nothing+                                (tAddr pp) nameGlobalMalloc+                                [xBytes'] []++                        -- Store the top-of-heap pointer+                        , IStore (XVar vTopPtr) (XVar vAddr)++                        -- Store the maximum heap pointer+                        , IOp    vMax OpAdd     (XVar vAddr) xBytes'+                        , IStore (XVar vMaxPtr) (XVar vMax) ]+++        -- Check that there is enough space to allocate a new heap object+        -- of the given number of bytes in length.+        A.PrimStore A.PrimStoreCheck+         | Just vDst@(Var nDst _)       <- mdst+         , Just [mBytes]                <- atomsR as+         -> Just $ do+                xBytes'     <- mBytes+                let vTop    = Var (bumpName nDst "top") (tAddr pp)+                let vMin    = Var (bumpName nDst "min") (tAddr pp)+                let vMax    = Var (bumpName nDst "max") (tAddr pp)+                let vTopPtr = varGlobalHeapTop pp+                let vMaxPtr = varGlobalHeapMax pp+                return  $ Seq.fromList $ map annotNil+                        [ ILoad vTop (XVar vTopPtr)+                        , IOp   vMin OpAdd (XVar vTop) xBytes'+                        , ILoad vMax (XVar vMaxPtr)+                        , ICmp  vDst (ICond ICondUlt) (XVar vMin) (XVar vMax) ]+++        -- Allocate a new heap object with the given number of bytes in length.+        A.PrimStore A.PrimStoreAlloc+         | Just vDst@(Var nDst _)       <- mdst+         , Just [mBytes]                <- atomsR as+         -> Just $ do+                xBytes'     <- mBytes+                let vBump   = Var (bumpName nDst "bump") (tAddr pp)+                let vTopPtr = varGlobalHeapTop pp+                return  $ Seq.fromList $ map annotNil+                        [ ILoad  vDst  (XVar vTopPtr)+                        , IOp    vBump OpAdd (XVar vDst) xBytes'+                        , IStore (XVar vTopPtr) (XVar vBump)]+++        -- Read a value via a pointer.+        A.PrimStore A.PrimStoreRead+         | A.RType{} : args             <- as+         , Just vDst@(Var nDst tDst)    <- mdst+         , Just [mAddr, mOffset]        <- atomsR args+         -> Just $ do+                xAddr'      <- mAddr+                xOffset'    <- mOffset+                let vOff    = Var (bumpName nDst "off") (tAddr pp)+                let vPtr    = Var (bumpName nDst "ptr") (tPtr tDst)+                return  $ Seq.fromList $ map annotNil+                        [ IOp   vOff OpAdd xAddr' xOffset'+                        , IConv vPtr ConvInttoptr (XVar vOff)+                        , ILoad vDst (XVar vPtr) ]+++        -- Write a value via a pointer.+        A.PrimStore A.PrimStoreWrite+         | A.RType{} : args             <- as+         , Just [mAddr, mOffset, mVal]  <- atomsR args+         -> Just $ do+                xAddr'   <- mAddr+                xOffset' <- mOffset+                xVal'    <- mVal+                vOff     <- newUniqueNamedVar "off" (tAddr pp)+                vPtr     <- newUniqueNamedVar "ptr" (tPtr $ typeOfExp xVal')+                return  $ Seq.fromList $ map annotNil+                        [ IOp    vOff OpAdd xAddr' xOffset'+                        , IConv  vPtr ConvInttoptr (XVar vOff)+                        , IStore (XVar vPtr) xVal' ]+++        -- Add an offset in bytes to a pointer.+        A.PrimStore A.PrimStorePlusAddr+         | Just vDst                    <- mdst+         , Just [mAddr, mOffset]        <- atomsR as+         -> Just $ do+                xAddr'   <- mAddr+                xOffset' <- mOffset+                return  $ Seq.singleton $ annotNil+                        $ IOp vDst OpAdd xAddr' xOffset'+++        -- Subtract an offset in bytes from a pointer.+        A.PrimStore A.PrimStoreMinusAddr+         | Just vDst                    <- mdst+         , Just [mAddr, mOffset]        <- atomsR as+         -> Just $ do+                xAddr'       <- mAddr+                xOffset'     <- mOffset+                return  $ Seq.singleton $ annotNil+                        $ IOp vDst OpSub xAddr' xOffset'+++        -- Read from a raw address.+        A.PrimStore A.PrimStorePeek+         | A.RType{} : A.RType tDst : args      <- as+         , Just vDst@(Var nDst _)               <- mdst+         , Just [mPtr, mOffset]                 <- atomsR args+         -> Just $ do+                tDst'        <- convertType   pp kenv tDst+                xPtr'        <- mPtr+                xOffset'     <- mOffset+                let vAddr1   = Var (bumpName nDst "addr1") (tAddr pp)+                let vAddr2   = Var (bumpName nDst "addr2") (tAddr pp)+                let vPtr     = Var (bumpName nDst "ptr")   (tPtr tDst')+                return  $ Seq.fromList+                        $ (map annotNil+                        [ IConv vAddr1 ConvPtrtoint xPtr'+                        , IOp   vAddr2 OpAdd (XVar vAddr1) xOffset'+                        , IConv vPtr   ConvInttoptr (XVar vAddr2) ])+                        ++ [(annot kenv mdsup as+                        ( ILoad vDst  (XVar vPtr)))]+++        -- Write to a raw address.+        A.PrimStore A.PrimStorePoke+         | A.RType{} : A.RType tDst : args      <- as+         , Just [mPtr, mOffset, mVal]           <- atomsR args+         -> Just $ do+                tDst'    <- convertType pp kenv tDst+                xPtr'    <- mPtr+                xOffset' <- mOffset+                xVal'    <- mVal+                vAddr1   <- newUniqueNamedVar "addr1" (tAddr pp)+                vAddr2   <- newUniqueNamedVar "addr2" (tAddr pp)+                vPtr     <- newUniqueNamedVar "ptr"   (tPtr tDst')+                return  $ Seq.fromList+                        $ (map annotNil+                        [ IConv vAddr1 ConvPtrtoint xPtr'+                        , IOp   vAddr2 OpAdd (XVar vAddr1) xOffset'+                        , IConv vPtr   ConvInttoptr (XVar vAddr2) ])+                        ++ [(annot kenv mdsup as+                        ( IStore (XVar vPtr) xVal' ))]+++        -- Add an offset to a raw address.+        A.PrimStore A.PrimStorePlusPtr+         | _xRgn : _xType : args        <- as+         , Just vDst                    <- mdst+         , Just [mPtr, mOffset]         <- atomsR args+         -> Just $ do+                xPtr'    <- mPtr+                xOffset' <- mOffset+                vAddr    <- newUniqueNamedVar "addr"   (tAddr pp)+                vAddr2   <- newUniqueNamedVar "addr2"  (tAddr pp)+                return  $ Seq.fromList $ map annotNil+                        [ IConv vAddr  ConvPtrtoint xPtr'+                        , IOp   vAddr2 OpAdd (XVar vAddr) xOffset'+                        , IConv vDst   ConvInttoptr (XVar vAddr2) ]+++        -- Subtrace an offset from a raw address.+        A.PrimStore A.PrimStoreMinusPtr+         | _xRgn : _xType : args        <- as+         , Just vDst                    <- mdst+         , Just [mPtr, mOffset]         <- atomsR args+         -> Just $ do+                xPtr'    <- mPtr+                xOffset' <- mOffset+                vAddr    <- newUniqueNamedVar "addr"   (tAddr pp)+                vAddr2   <- newUniqueNamedVar "addr2"  (tAddr pp)+                return  $ Seq.fromList $ map annotNil+                        [ IConv vAddr  ConvPtrtoint xPtr'+                        , IOp   vAddr2 OpSub (XVar vAddr) xOffset'+                        , IConv vDst   ConvInttoptr (XVar vAddr2) ]+++        -- Construct a pointer from an address.+        A.PrimStore A.PrimStoreMakePtr+         | [A.RType{}, A.RType{}, A.RExp xAddr] <- as+         , Just vDst    <- mdst+         , Just mAddr   <- atom xAddr+         -> Just $ do+                xAddr'  <- mAddr+                return  $ Seq.singleton $ annotNil+                        $ IConv vDst ConvInttoptr xAddr'+++        -- Take an address from a pointer.+        A.PrimStore A.PrimStoreTakePtr+         | [A.RType{}, A.RType{}, A.RExp xPtr] <- as+         , Just vDst    <- mdst+         , Just mPtr    <- atom xPtr+         -> Just $ do+                xPtr'   <- mPtr+                return  $ Seq.singleton $ annotNil+                        $ IConv vDst ConvPtrtoint xPtr'+++        -- Case a pointer from one type to another.+        A.PrimStore A.PrimStoreCastPtr+         | [A.RType{}, A.RType{}, A.RType{}, A.RExp xPtr] <- as+         , Just vDst    <- mdst+         , Just mPtr    <- atom xPtr+         -> Just $ do  +                xPtr'   <- mPtr+                return  $ Seq.singleton $ annotNil+                        $ IConv vDst ConvBitcast xPtr'++        _ -> Nothing+++-- | Append the given string to a name.+bumpName :: Name -> String -> Name+bumpName nn s+ = case nn of+        NameLocal str   -> NameLocal  (str ++ "." ++ s)+        NameGlobal str  -> NameGlobal (str ++ "." ++ s)+

@@ -1,454 +0,0 @@--module DDC.Core.Llvm.Convert.Prim-        (convPrimCallM)-where-import DDC.Llvm.Syntax-import DDC.Core.Llvm.Convert.Atom-import DDC.Core.Llvm.Convert.Type-import DDC.Core.Llvm.Metadata.Tbaa-import DDC.Core.Llvm.LlvmM-import DDC.Core.Salt.Platform-import DDC.Core.Compounds-import DDC.Base.Pretty-import DDC.Type.Env             (KindEnv, TypeEnv)-import Data.Sequence            (Seq)-import qualified DDC.Core.Exp   as C-import qualified DDC.Core.Salt  as A-import qualified Data.Sequence  as Seq----- Prim call --------------------------------------------------------------------- | Convert a primitive call to LLVM.-convPrimCallM-        :: Show a-        => Platform-        -> KindEnv A.Name-        -> TypeEnv A.Name-        -> MDSuper              -- ^ Metadata for the enclosing super-        -> Maybe Var            -- ^ Assign result to this var.-        -> A.PrimOp             -- ^ Prim to call.-        -> C.Type A.Name        -- ^ Type of prim.-        -> [C.Exp a A.Name]     -- ^ Arguments to prim.-        -> LlvmM (Seq AnnotInstr)--convPrimCallM pp kenv tenv mdsup mdst p _tPrim xs- = case p of-        -- Binary operations -----------        A.PrimArith op-         | C.XType _ t : args     <- xs-         , Just [x1', x2']      <- mconvAtoms pp kenv tenv args-         , Just dst             <- mdst-         -> let result-                 | Just op'     <- convPrimArith2 op t-                 = IOp dst op' x1' x2'--                 | Just icond'  <- convPrimICond op t-                 = IICmp dst icond' x1' x2'--                 | Just fcond'  <- convPrimFCond op t-                 = IFCmp dst fcond' x1' x2'--                 | otherwise-                 = die $ "Invalid binary primop."-           in   return $ Seq.singleton (annotNil result)--        -- Cast primops ----------------        A.PrimCast A.PrimCastPromote-         | [C.XType _ tDst, C.XType _ tSrc, xSrc] <- xs-         , Just xSrc'           <- mconvAtom pp kenv tenv xSrc-         , Just vDst            <- mdst-         , minstr               <- convPrimPromote pp kenv tDst vDst tSrc xSrc'-         -> case minstr of-                Just instr      -> return $ Seq.singleton (annotNil instr)-                Nothing         -> dieDoc $ vcat-                                [ text "Invalid promotion of numeric value."-                                , text "  from type: " <> ppr tSrc-                                , text "    to type: " <> ppr tDst]--        A.PrimCast A.PrimCastTruncate-         | [C.XType _ tDst, C.XType _ tSrc, xSrc] <- xs-         , Just xSrc'           <- mconvAtom pp kenv tenv xSrc-         , Just vDst            <- mdst-         , minstr               <- convPrimTruncate pp kenv tDst vDst tSrc xSrc'-         -> case minstr of-                Just instr      -> return $ Seq.singleton (annotNil instr)-                Nothing         -> dieDoc $ vcat-                                [ text "Invalid truncation of numeric value."-                                , text " from type: " <> ppr tSrc-                                , text "   to type: " <> ppr tDst ]--        -- Store primops ---------------        A.PrimStore A.PrimStoreSize-         | [C.XType _ t]        <- xs-         , Just vDst            <- mdst-         -> let t'      = convertType pp kenv t-                size    = case t' of-                            TPointer _           -> platformAddrBytes pp-                            TInt bits-                             | bits `rem` 8 == 0 -> bits `div` 8-                            _                    -> sorry--                -- Bool# is only 1 bit long.-                -- Don't return a result for types that don't divide into 8 bits evenly.-                sorry           = dieDoc $ vcat-                                [ text "  Invalid type applied to size#."]--            in return   $ Seq.singleton-                        $ annotNil-                        $ ISet vDst (XLit (LitInt (tNat pp) size))---        A.PrimStore A.PrimStoreSize2-         | [C.XType _ t]        <- xs-         , Just vDst            <- mdst-         -> let t'      = convertType pp kenv t-                size    = case t' of-                            TPointer _           -> platformAddrBytes pp-                            TInt bits-                             | bits `rem` 8 == 0 -> bits `div` 8-                            _                    -> sorry--                size2   = truncate $ (log (fromIntegral size) / log 2 :: Double)--                -- Bool# is only 1 bit long.-                -- Don't return a result for types that don't divide into 8 bits evenly.-                sorry           = dieDoc $ vcat-                                [ text "  Invalid type applied to size2#."]--            in return   $ Seq.singleton-                        $ annotNil-                        $ ISet vDst (XLit (LitInt (tNat pp) size2))---        A.PrimStore A.PrimStoreCreate-         | Just [xBytes']         <- mconvAtoms pp kenv tenv xs-         -> do  vAddr   <- newUniqueNamedVar "addr" (tAddr pp)-                vMax    <- newUniqueNamedVar "max"  (tAddr pp)-                let vTopPtr = Var (NameGlobal "_DDC__heapTop") (TPointer (tAddr pp))-                let vMaxPtr = Var (NameGlobal "_DDC__heapMax") (TPointer (tAddr pp))-                return  $ Seq.fromList-                        $ map annotNil-                        [ ICall (Just vAddr) CallTypeStd Nothing-                                (tAddr pp) (NameGlobal "malloc")-                                [xBytes'] []--                        -- Store the top-of-heap pointer-                        , IStore (XVar vTopPtr) (XVar vAddr)--                        -- Store the maximum heap pointer-                        , IOp    vMax OpAdd     (XVar vAddr) xBytes'-                        , IStore (XVar vMaxPtr) (XVar vMax) ]---        A.PrimStore A.PrimStoreCheck-         | Just [xBytes']         <- mconvAtoms pp kenv tenv xs-         , Just vDst@(Var nDst _) <- mdst-         -> do  let vTop    = Var (bumpName nDst "top") (tAddr pp)-                let vMin    = Var (bumpName nDst "min") (tAddr pp)-                let vMax    = Var (bumpName nDst "max") (tAddr pp)-                let vTopPtr = Var (NameGlobal "_DDC__heapTop") (TPointer (tAddr pp))-                let vMaxPtr = Var (NameGlobal "_DDC__heapMax") (TPointer (tAddr pp))-                return  $ Seq.fromList-                        $ map annotNil-                        [ ILoad vTop (XVar vTopPtr)-                        , IOp   vMin OpAdd (XVar vTop) xBytes'-                        , ILoad vMax (XVar vMaxPtr)-                        , IICmp vDst ICondUlt (XVar vMin) (XVar vMax) ]--        A.PrimStore A.PrimStoreAlloc-         | Just vDst@(Var nDst _) <- mdst-         , Just [xBytes']         <- mconvAtoms pp kenv tenv xs-         -> do  let vBump   = Var (bumpName nDst "bump") (tAddr pp)-                let vTopPtr = Var (NameGlobal "_DDC__heapTop") (TPointer (tAddr pp))-                return  $ Seq.fromList-                        $ map annotNil-                        [ ILoad  vDst  (XVar vTopPtr)-                        , IOp    vBump OpAdd (XVar vDst) xBytes'-                        , IStore (XVar vTopPtr) (XVar vBump)]--        A.PrimStore A.PrimStoreRead-         | C.XType{} : args             <- xs-         , Just [xAddr', xOffset']      <- mconvAtoms pp kenv tenv args-         , Just vDst@(Var nDst tDst)    <- mdst-         -> let vOff    = Var (bumpName nDst "off") (tAddr pp)-                vPtr    = Var (bumpName nDst "ptr") (tPtr tDst)-            in  return  $ Seq.fromList-                        $ map annotNil-                        [ IOp   vOff OpAdd xAddr' xOffset'-                        , IConv vPtr ConvInttoptr (XVar vOff)-                        , ILoad vDst (XVar vPtr) ]--        A.PrimStore A.PrimStoreWrite-         | C.XType{} : args              <- xs-         , Just [xAddr', xOffset', xVal'] <- mconvAtoms pp kenv tenv args-         -> do  vOff    <- newUniqueNamedVar "off" (tAddr pp)-                vPtr    <- newUniqueNamedVar "ptr" (tPtr $ typeOfExp xVal')-                return  $ Seq.fromList-                        $ map annotNil-                        [ IOp    vOff OpAdd xAddr' xOffset'-                        , IConv  vPtr ConvInttoptr (XVar vOff)-                        , IStore (XVar vPtr) xVal' ]--        A.PrimStore A.PrimStorePlusAddr-         | Just [xAddr', xOffset']      <- mconvAtoms pp kenv tenv xs-         , Just vDst                    <- mdst-         ->     return  $ Seq.singleton $ annotNil-                        $ IOp vDst OpAdd xAddr' xOffset'--        A.PrimStore A.PrimStoreMinusAddr-         | Just [xAddr', xOffset']      <- mconvAtoms pp kenv tenv xs-         , Just vDst                    <- mdst-         ->     return  $ Seq.singleton $ annotNil-                        $ IOp vDst OpSub xAddr' xOffset'--        A.PrimStore A.PrimStorePeek-         | C.XType{} : C.XType _ tDst : args     <- xs-         , Just [xPtr', xOffset']       <- mconvAtoms pp kenv tenv args-         , Just vDst@(Var nDst _)       <- mdst-         , tDst'                        <- convertType   pp kenv tDst-         -> let vAddr1   = Var (bumpName nDst "addr1") (tAddr pp)-                vAddr2   = Var (bumpName nDst "addr2") (tAddr pp)-                vPtr     = Var (bumpName nDst "ptr")   (tPtr tDst')-            in  return  $ Seq.fromList-                        $ (map annotNil-                        [ IConv vAddr1 ConvPtrtoint xPtr'-                        , IOp   vAddr2 OpAdd (XVar vAddr1) xOffset'-                        , IConv vPtr   ConvInttoptr (XVar vAddr2) ])-                        ++ [(annot kenv mdsup xs-                        ( ILoad vDst  (XVar vPtr)))]--        A.PrimStore A.PrimStorePoke-         | C.XType{} : C.XType _ tDst : args     <- xs-         , Just [xPtr', xOffset', xVal'] <- mconvAtoms pp kenv tenv args-         , tDst'                         <- convertType   pp kenv tDst-         -> do  vAddr1  <- newUniqueNamedVar "addr1" (tAddr pp)-                vAddr2  <- newUniqueNamedVar "addr2" (tAddr pp)-                vPtr    <- newUniqueNamedVar "ptr"   (tPtr tDst')-                return  $ Seq.fromList-                        $ (map annotNil-                        [ IConv vAddr1 ConvPtrtoint xPtr'-                        , IOp   vAddr2 OpAdd (XVar vAddr1) xOffset'-                        , IConv vPtr   ConvInttoptr (XVar vAddr2) ])-                        ++ [(annot kenv mdsup xs-                        ( IStore (XVar vPtr) xVal' ))]--        A.PrimStore A.PrimStorePlusPtr-         | _xRgn : _xType : args        <- xs-         , Just [xPtr', xOffset']       <- mconvAtoms pp kenv tenv args-         , Just vDst                    <- mdst-         -> do  vAddr   <- newUniqueNamedVar "addr"   (tAddr pp)-                vAddr2  <- newUniqueNamedVar "addr2"  (tAddr pp)-                return  $ Seq.fromList-                        $ map annotNil-                        [ IConv vAddr  ConvPtrtoint xPtr'-                        , IOp   vAddr2 OpAdd (XVar vAddr) xOffset'-                        , IConv vDst   ConvInttoptr (XVar vAddr2) ]--        A.PrimStore A.PrimStoreMinusPtr-         | _xRgn : _xType : args        <- xs-         , Just [xPtr', xOffset']       <- mconvAtoms pp kenv tenv args-         , Just vDst                    <- mdst-         -> do  vAddr   <- newUniqueNamedVar "addr"   (tAddr pp)-                vAddr2  <- newUniqueNamedVar "addr2"  (tAddr pp)-                return  $ Seq.fromList-                        $ map annotNil-                        [ IConv vAddr  ConvPtrtoint xPtr'-                        , IOp   vAddr2 OpSub (XVar vAddr) xOffset'-                        , IConv vDst   ConvInttoptr (XVar vAddr2) ]--        A.PrimStore A.PrimStoreMakePtr-         | [C.XType{}, C.XType{}, xAddr] <- xs-         , Just xAddr'  <- mconvAtom pp kenv tenv xAddr-         , Just vDst    <- mdst-         ->     return  $ Seq.singleton $ annotNil-                        $ IConv vDst ConvInttoptr xAddr'--        A.PrimStore A.PrimStoreTakePtr-         | [C.XType{}, C.XType{}, xPtr]          <- xs-         , Just xPtr'   <- mconvAtom pp kenv tenv xPtr-         , Just vDst    <- mdst-         ->     return  $ Seq.singleton $ annotNil-                        $ IConv vDst ConvPtrtoint xPtr'--        A.PrimStore A.PrimStoreCastPtr-         | [C.XType{}, C.XType{}, C.XType{}, xPtr] <- xs-         , Just xPtr'   <- mconvAtom pp kenv tenv xPtr-         , Just vDst    <- mdst-         ->     return  $ Seq.singleton $ annotNil-                        $ IConv vDst ConvBitcast xPtr'--        _ -> die $ unlines-                [ "Invalid prim call."-                , show (p, xs) ]---bumpName :: Name -> String -> Name-bumpName nn s- = case nn of-        NameLocal str   -> NameLocal  (str ++ "." ++ s)-        NameGlobal str  -> NameGlobal (str ++ "." ++ s)----- Op ---------------------------------------------------------------------------- | Convert a binary primop from Core Sea to LLVM form.-convPrimArith2 :: A.PrimArith -> C.Type A.Name -> Maybe Op-convPrimArith2 op t- = case op of-        A.PrimArithAdd-         | isIntegralT t                -> Just OpAdd-         | isFloatingT t                -> Just OpFAdd--        A.PrimArithSub-         | isIntegralT t                -> Just OpSub-         | isFloatingT t                -> Just OpFSub--        A.PrimArithMul-         | isIntegralT t                -> Just OpMul-         | isFloatingT t                -> Just OpFMul--        A.PrimArithDiv-         | isIntegralT t, isUnsignedT t -> Just OpUDiv-         | isIntegralT t, isSignedT t   -> Just OpSDiv-         | isFloatingT t                -> Just OpFDiv--        A.PrimArithRem-         | isIntegralT t, isUnsignedT t -> Just OpURem-         | isIntegralT t, isSignedT t   -> Just OpSRem-         | isFloatingT t                -> Just OpFRem--        A.PrimArithShl-         | isIntegralT t                -> Just OpShl--        A.PrimArithShr-         | isIntegralT t, isUnsignedT t -> Just OpLShr-         | isIntegralT t, isSignedT t   -> Just OpAShr--        A.PrimArithBAnd-         | isIntegralT t                -> Just OpAnd--        A.PrimArithBOr-         | isIntegralT t                -> Just OpOr--        A.PrimArithBXOr-         | isIntegralT t                -> Just OpXor--        _                               -> Nothing----- Cast -------------------------------------------------------------------------- | Convert a primitive promotion to LLVM,---   or `Nothing` for an invalid promotion.-convPrimPromote-        :: Platform-        -> KindEnv A.Name-        -> C.Type A.Name -> Var-        -> C.Type A.Name -> Exp-        -> Maybe Instr--convPrimPromote pp kenv tDst vDst tSrc xSrc- | tSrc'        <- convertType pp kenv tSrc- , tDst'        <- convertType pp kenv tDst- , Just (A.NamePrimTyCon tcSrc, _) <- takePrimTyConApps tSrc- , Just (A.NamePrimTyCon tcDst, _) <- takePrimTyConApps tDst- , A.primCastPromoteIsValid pp tcSrc tcDst- = case (tDst', tSrc') of-        (TInt bitsDst, TInt bitsSrc)--         -- Same sized integers-         | bitsDst == bitsSrc-         -> Just $ ISet vDst xSrc--         -- Both Unsigned-         | isUnsignedT tSrc-         , isUnsignedT tDst-         , bitsDst > bitsSrc-         -> Just $ IConv vDst ConvZext xSrc--         -- Both Signed-         | isSignedT tSrc-         , isSignedT tDst-         , bitsDst > bitsSrc-         -> Just $ IConv vDst ConvSext xSrc--         -- Unsigned to Signed-         | isUnsignedT tSrc-         , isSignedT   tDst-         , bitsDst > bitsSrc-         -> Just $ IConv vDst ConvZext xSrc--        _ -> Nothing-- | otherwise- = Nothing----- | Convert a primitive truncation to LLVM,---   or `Nothing` for an invalid truncation.-convPrimTruncate-        :: Platform-        -> KindEnv A.Name-        -> C.Type  A.Name -> Var-        -> C.Type  A.Name -> Exp-        -> Maybe Instr--convPrimTruncate pp kenv tDst vDst tSrc xSrc- | tSrc'        <- convertType pp kenv tSrc- , tDst'        <- convertType pp kenv tDst- , Just (A.NamePrimTyCon tcSrc, _) <- takePrimTyConApps tSrc- , Just (A.NamePrimTyCon tcDst, _) <- takePrimTyConApps tDst- , A.primCastTruncateIsValid pp tcSrc tcDst- = case (tDst', tSrc') of-        (TInt bitsDst, TInt bitsSrc)-         -- Same sized integers-         | bitsDst == bitsSrc-         -> Just $ ISet vDst xSrc--         -- Destination is smaller-         | bitsDst < bitsSrc-         -> Just $ IConv vDst ConvTrunc xSrc--         -- Unsigned to Signed,-         --  destination is larger-         | bitsDst > bitsSrc-         , isUnsignedT tSrc-         , isSignedT   tDst-         -> Just $ IConv vDst ConvZext xSrc--        _ -> Nothing-- | otherwise- = Nothing----- Cond -------------------------------------------------------------------------- | Convert an integer comparison from Core Sea to LLVM form.-convPrimICond :: A.PrimArith -> C.Type A.Name -> Maybe ICond-convPrimICond op t- | isIntegralT t- = case op of-        A.PrimArithEq   -> Just ICondEq-        A.PrimArithNeq  -> Just ICondNe-        A.PrimArithGt   -> Just ICondUgt-        A.PrimArithGe   -> Just ICondUge-        A.PrimArithLt   -> Just ICondUlt-        A.PrimArithLe   -> Just ICondUle-        _               -> Nothing-- | otherwise            =  Nothing----- | Convert a floating point comparison from Core Sea to LLVM form.-convPrimFCond :: A.PrimArith -> C.Type A.Name -> Maybe FCond-convPrimFCond op t- | isIntegralT t- = case op of-        A.PrimArithEq   -> Just FCondOeq-        A.PrimArithNeq  -> Just FCondOne-        A.PrimArithGt   -> Just FCondOgt-        A.PrimArithGe   -> Just FCondOge-        A.PrimArithLt   -> Just FCondOlt-        A.PrimArithLe   -> Just FCondOle-        _               -> Nothing-- | otherwise            =  Nothing-

@@ -1,23 +1,22 @@+{-# LANGUAGE TypeFamilies #-}  module DDC.Core.Llvm.Convert.Super-        (convSuperM)+        (convertSuper) where import DDC.Core.Llvm.Convert.Exp import DDC.Core.Llvm.Convert.Type-import DDC.Core.Llvm.Convert.Erase-import DDC.Core.Llvm.LlvmM+import DDC.Core.Llvm.Convert.Context+import DDC.Core.Llvm.Convert.Base import DDC.Llvm.Syntax import DDC.Core.Salt.Platform-import DDC.Core.Compounds+import DDC.Type.Predicates import DDC.Base.Pretty                          hiding (align)-import DDC.Type.Env                             (KindEnv, TypeEnv)-import Control.Monad.State.Strict               (gets) import qualified DDC.Core.Llvm.Metadata.Tbaa    as Tbaa import qualified DDC.Core.Salt                  as A import qualified DDC.Core.Salt.Convert          as A+import qualified DDC.Core.Exp.Generic.Compounds 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 Data.Set                       as Set import qualified Data.Sequence                  as Seq import qualified Data.Foldable                  as Seq@@ -25,20 +24,21 @@  -- | Convert a top-level supercombinator to a LLVM function. --   Region variables are completely stripped out.-convSuperM -        :: 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])+convertSuper+        :: Context+        -> A.Bind       -- ^ Bind of the top-level super.+        -> A.Exp        -- ^ Super body.+        -> ConvertM (Function, [MDecl]) -convSuperM kenv tenv bSuper@(C.BName nSuper tSuper) x- | Just (bfsParam, xBody)  <- takeXLamFlags x+convertSuper ctx (C.BName nSuper tSuper) x+ | Just (asParam, xBody)  <- A.takeXAbs x  = do   -        platform        <- gets llvmStatePlatform-        mm              <- gets llvmStateModule+        let pp          = contextPlatform ctx+        let mm          = contextModule   ctx+        let kenv        = contextKindEnv  ctx -        let nsExports    = Set.fromList $ map fst $ C.moduleExportValues mm+        -- Collect names of exported values.+        let nsExports   = Set.fromList $ map fst $ C.moduleExportValues mm          -- Sanitise the super name so we can use it as a symbol         -- in the object code.@@ -47,21 +47,24 @@                                 (lookup nSuper (C.moduleExportValues mm))                                 nSuper -        -- Add parameters to environments.-        let bfsParam'    = eraseWitBinds bfsParam-        let bsParamType  = [b | (True,  b) <- bfsParam']-        let bsParamValue = [b | (False, b) <- bfsParam']+        -- Add super parameters to the context.+        (ctx', vsParamValue')+                  <- bindLocalAs ctx $ eraseWitBinds $ asParam -        let kenv'       =  Env.extends bsParamType  kenv-        let tenv'       =  Env.extends (bSuper : bsParamValue) tenv-        mdsup           <- Tbaa.deriveMD (renderPlain nSuper') x+        -- Add super meta-data to the context.+        mdsup     <- Tbaa.deriveMD (renderPlain nSuper') x+        let ctx'' = ctx' { contextMDSuper = mdsup } +        -- Convert function body to basic blocks.+        label     <- newUniqueLabel "entry"+        blocks    <- convertBody ctx'' ExpTop Seq.empty label Seq.empty xBody+         -- Split off the argument and result types of the super.-        let (tsParam, tResult)   -                        = convertSuperType platform kenv tSuper+        (tsParam, tResult)   +                  <- convertSuperType pp kenv tSuper            -- Make parameter binders.-        let align       = AlignBytes (platformAlignBytes platform)+        let align = AlignBytes (platformAlignBytes pp)          -- Declaration of the super.         let decl @@ -86,41 +89,42 @@                                                 then CC_Ccc                                                 else CC_Fastcc -                , declReturnType         = tResult-                , declParamListType      = FixedArgs-                , declParams             = [Param t [] | t <- tsParam]-                , declAlign              = align }+                , 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+        let Just ssParamValues+                = sequence+                $ map (\v -> case v of +                                (Var (NameLocal s) _) -> Just s+                                _                     -> Nothing)+                $ vsParamValue' +         -- Build the function.-        return  $ ( Function-                    { funDecl     = decl-                    , funParams   = [nameOfParam i b -                                        | i <- [0..]-                                        | b <- bsParamValue]-                    , funAttrs    = [] -                    , funSection  = SectionAuto-                    , funBlocks   = Seq.toList blocks }-                  , Tbaa.decls mdsup )-                  +        return  ( Function+                  { funDecl     = decl+                  , funParams   = ssParamValues+                  , funAttrs    = [] +                  , funSection  = SectionAuto+                  , funBlocks   = Seq.toList blocks }+                , Tbaa.decls mdsup )  -convSuperM _ _ _ _-        = die "Invalid super"+convertSuper _ b x+        = throw $ ErrorInvalidSuper b x  --- | Take the string name to use for a function parameter.-nameOfParam :: Int -> C.Bind A.Name -> String-nameOfParam i bb- = case bb of-        C.BName (A.NameVar n) _ -           -> A.sanitizeName n--        C.BNone _-           -> "_arg" ++ show i--        _  -> die $ "Invalid parameter name: " ++ show bb+---------------------------------------------------------------------------------------------------+-- | Erase witness bindings+eraseWitBinds :: [A.GAbs A.Name] -> [A.GAbs A.Name]+eraseWitBinds+ = let +        isBindWit (A.ALAM _) = False+        isBindWit (A.ALam b) +          = case b of+                 C.BName _ t | isWitnessType t -> True+                 _                             -> False +   in  filter (not . isBindWit) 

@@ -20,18 +20,17 @@         , isIntegralT         , isFloatingT) where+import DDC.Core.Llvm.Convert.Base import DDC.Llvm.Syntax.Type import DDC.Llvm.Syntax.Attr-import DDC.Core.Llvm.LlvmM import DDC.Core.Salt.Platform-import DDC.Core.Llvm.Convert.Erase import DDC.Type.Env import DDC.Type.Compounds import DDC.Type.Predicates import DDC.Base.Pretty-import DDC.Core.Salt                    as A-import DDC.Core.Salt.Name               as A-import DDC.Core.Salt.Convert            as A+import qualified DDC.Core.Salt          as A+import qualified DDC.Core.Salt.Name     as A+import qualified DDC.Core.Salt.Convert  as A import qualified DDC.Core.Module        as C import qualified DDC.Core.Exp           as C import qualified DDC.Type.Env           as Env@@ -40,7 +39,7 @@  -- Type ----------------------------------------------------------------------- -- | Convert a Salt type to an LlvmType.-convertType :: Platform -> KindEnv Name -> C.Type Name -> Type+convertType :: Platform -> KindEnv A.Name -> C.Type A.Name -> ConvertM Type convertType pp kenv tt  = case tt of         -- A polymorphic type,@@ -48,42 +47,50 @@         C.TVar u          -> case Env.lookup u kenv of              Nothing            -              -> die $ "Type variable not in kind environment." ++ show u+              -> throw $ ErrorInvalidBound u+                       $ Just "Type variable not in kind environment."               Just k-              | isDataKind k    -> TPointer (tObj pp)-              | otherwise       -> die "Invalid type variable."+              | isDataKind k    +              -> return $ TPointer (tObj pp) +              | otherwise       +              -> throw $ ErrorInvalidBound u+                       $ Just "Bound type variable does not have kind Data."+         -- A primitive type.         C.TCon tc           -> convTyCon pp tc          -- A pointer to a primitive type.         C.TApp{}-         | Just (NamePrimTyCon PrimTyConPtr, [_r, t2]) +         | Just (A.NamePrimTyCon A.PrimTyConPtr, [_r, t2])                  <- takePrimTyConApps tt-         -> TPointer (convertType pp kenv t2)+         -> do  t2'     <- convertType pp kenv t2+                return  $ TPointer t2'          -- Function types become pointers to functions.         C.TApp{}-         |  (tsArgs, tResult)    <- convertSuperType pp kenv tt-         -> TPointer $ TFunction -         $  FunctionDecl-             { declName          = "dummy.function.name"-             , declLinkage       = Internal-             , declCallConv      = CC_Ccc-             , declReturnType    = tResult-             , declParamListType = FixedArgs-             , declParams        = [Param t [] | t <- tsArgs]-             , declAlign         = AlignBytes (platformAlignBytes pp) }+         -> do  (tsArgs, tResult)    <- convertSuperType pp kenv tt+                return  +                  $ TPointer $ TFunction +                  $ FunctionDecl+                  { declName          = "dummy.function.name"+                  , declLinkage       = Internal+                  , declCallConv      = CC_Ccc+                  , declReturnType    = tResult+                  , declParamListType = FixedArgs+                  , declParams        = [Param t [] | t <- tsArgs]+                  , declAlign         = AlignBytes (platformAlignBytes pp) }                  C.TForall b t          -> let kenv'   = Env.extend b kenv             in  convertType pp kenv' t           -        _ -> die ("Invalid Type " ++ show tt)-        +        _ -> throw $ ErrorInvalidType tt+                   $ Just "Cannot convert type." + -- Super Type ----------------------------------------------------------------- -- | Split the parameter and result types from a supercombinator type and --   and convert them to LLVM form. @@ -92,66 +99,70 @@ --   to decend into any quantifiers that wrap the body type. convertSuperType          :: Platform-        -> KindEnv Name-        -> C.Type  Name-        -> ([Type], Type)+        -> KindEnv A.Name+        -> C.Type  A.Name+        -> ConvertM ([Type], Type)  convertSuperType pp kenv tt- = let tt' = eraseWitTApps tt-   in  case tt' of-            C.TApp{}-             |  (tsArgs, tResult)    <- takeTFunArgResult tt'-             ,  not $ null tsArgs-             -> let tsArgs'  = map (convertType pp kenv) tsArgs-                    tResult' = convertType pp kenv tResult-                in  (tsArgs', tResult')+ = case tt of+        C.TApp{}+         |  (_, tsArgs, tResult) <- takeTFunWitArgResult tt+         ,  not $ null tsArgs+         -> do  tsArgs'   <- mapM (convertType pp kenv) tsArgs+                tResult'  <- convertType pp kenv tResult+                return (tsArgs', tResult') -            C.TForall b t-             -> let kenv' = Env.extend b kenv-                in  convertSuperType pp kenv' t+        C.TForall b t+         -> let kenv' = Env.extend b kenv+            in  convertSuperType pp kenv' t -            _ -> die ("Invalid super type" ++ show tt')+        _ -> throw $ ErrorInvalidType tt+                   $ Just $ "Cannot use this as the type of a super."+                          ++ show (takeTFunArgResult tt)   -- Imports -------------------------------------------------------------------- -- | Convert an imported function type to a LLVM declaration. importedFunctionDeclOfType          :: Platform-        -> KindEnv Name-        -> C.ImportSource Name-        -> Maybe (C.ExportSource Name)-        -> Name-        -> C.Type Name -        -> Maybe FunctionDecl+        -> KindEnv A.Name+        -> C.ImportValue A.Name+        -> Maybe (C.ExportSource A.Name)+        -> A.Name+        -> C.Type A.Name +        -> Maybe (ConvertM FunctionDecl)  importedFunctionDeclOfType pp kenv isrc mesrc nSuper tt  - | C.ImportSourceModule{} <- isrc- = let  Just strName = liftM renderPlain -                     $ seaNameOfSuper (Just isrc) mesrc nSuper+ | C.ImportValueModule{} <- isrc+ = Just $ do+        let Just strName +                = liftM renderPlain +                $ A.seaNameOfSuper (Just isrc) mesrc nSuper         -        (tsArgs, tResult)         = convertSuperType pp kenv tt-        mkParam t                 = Param t []-   in   Just $ FunctionDecl-             { declName           = A.sanitizeName strName-             , declLinkage        = External-             , declCallConv       = CC_Ccc-             , declReturnType     = tResult-             , declParamListType  = FixedArgs-             , declParams         = map mkParam tsArgs-             , declAlign          = AlignBytes (platformAlignBytes pp) }+        (tsArgs, tResult)       <- convertSuperType pp kenv tt+        let mkParam t           = Param t []+        return  $ FunctionDecl+                { declName           = A.sanitizeName strName+                , declLinkage        = External+                , declCallConv       = CC_Ccc+                , declReturnType     = tResult+                , declParamListType  = FixedArgs+                , declParams         = map mkParam tsArgs+                , declAlign          = AlignBytes (platformAlignBytes pp) } - | C.ImportSourceSea strName _ <- isrc- = let  (tsArgs, tResult)         = convertSuperType pp kenv tt-        mkParam t                 = Param t []-   in   Just $ FunctionDecl-             { declName           = A.sanitizeName strName-             , declLinkage        = External-             , declCallConv       = CC_Ccc-             , declReturnType     = tResult-             , declParamListType  = FixedArgs-             , declParams         = map mkParam tsArgs-             , declAlign          = AlignBytes (platformAlignBytes pp) }+ | C.ImportValueSea strName _  <- isrc+ = Just $ do+        (tsArgs, tResult)       <- convertSuperType pp kenv tt+        let mkParam t           = Param t []+        return  $ FunctionDecl+                { declName           = A.sanitizeName strName+                , declLinkage        = External+                , declCallConv       = CC_Ccc+                , declReturnType     = tResult+                , declParamListType  = FixedArgs+                , declParams         = map mkParam tsArgs+                , declAlign          = AlignBytes (platformAlignBytes pp) }  importedFunctionDeclOfType _ _ _ _ _ _         = Nothing@@ -159,37 +170,43 @@  -- TyCon ---------------------------------------------------------------------- -- | Convert a Sea TyCon to a LlvmType.-convTyCon :: Platform -> C.TyCon Name -> Type+convTyCon :: Platform -> C.TyCon A.Name -> ConvertM Type convTyCon platform tycon  = case tycon of         C.TyConSpec  C.TcConUnit-         -> tObj platform+         -> return $ TPointer (tObj platform) -        C.TyConBound (C.UPrim NameObjTyCon _) _-         -> tObj platform+        C.TyConBound (C.UPrim A.NameObjTyCon _) _+         -> return $ tObj platform -        C.TyConBound (C.UPrim (NamePrimTyCon tc) _) _+        C.TyConBound (C.UPrim (A.NamePrimTyCon tc) _) _          -> case tc of-                PrimTyConVoid           -> TVoid-                PrimTyConBool           -> TInt 1-                PrimTyConNat            -> TInt (8 * platformAddrBytes platform)-                PrimTyConInt            -> TInt (8 * platformAddrBytes platform)-                PrimTyConWord bits      -> TInt (fromIntegral bits)-                PrimTyConTag            -> TInt (8 * platformTagBytes  platform)-                PrimTyConAddr           -> TInt (8 * platformAddrBytes platform)-                PrimTyConString         -> TPointer (TInt 8)+             A.PrimTyConVoid      -> return $ TVoid+             A.PrimTyConBool      -> return $ TInt 1+             A.PrimTyConNat       -> return $ TInt (8 * platformAddrBytes platform)+             A.PrimTyConInt       -> return $ TInt (8 * platformAddrBytes platform)+             A.PrimTyConWord bits -> return $ TInt (fromIntegral bits)+             A.PrimTyConTag       -> return $ TInt (8 * platformTagBytes  platform)+             A.PrimTyConAddr      -> return $ TInt (8 * platformAddrBytes platform) -                PrimTyConFloat bits-                 -> case bits of-                        32      -> TFloat-                        64      -> TDouble-                        80      -> TFloat80-                        128     -> TFloat128-                        _       -> die "Invalid width for float type constructor."+             A.PrimTyConFloat bits+              -> case bits of+                        32        -> return TFloat+                        64        -> return TDouble+                        80        -> return TFloat80+                        128       -> return TFloat128 -                _               -> die "Invalid primitive type constructor."+                        _ -> throw $ ErrorInvalidTyCon tycon+                                   $ Just "Float has a non-standard width." -        _ -> die $ "Invalid type constructor '" ++ show tycon ++ "'"+             -- Text literals are represented as pointers to the static text data.+             A.PrimTyConTextLit   -> return $ tPtr (TInt 8)++             _            -> throw $ ErrorInvalidTyCon tycon+                                   $ Just "Not a primitive type constructor."++        _ -> throw $ ErrorInvalidTyCon tycon+                   $ Just "Cannot convert type constructor."   -- | Type of Heap objects.

@@ -1,121 +0,0 @@--module DDC.Core.Llvm.LlvmM-        ( LlvmM-        , LlvmState(..)-        , llvmStateInit -        , die-        , dieDoc--          -- * Uniques-        , newUnique-        , newUniqueVar-        , newUniqueNamedVar-        , newUniqueLabel--          -- * Platform Specific-        , getPrimDeclM-        , getBytesOfTypeM)-where-import DDC.Core.Salt.Platform-import DDC.Llvm.Syntax-import Data.Map                         (Map)-import qualified DDC.Core.Salt.Name     as A-import qualified DDC.Core.Module        as C-import qualified Data.Map               as Map-import Control.Monad.State.Strict-import DDC.Base.Pretty--type LlvmM = State LlvmState----- | Called when we find a thing that cannot be converted to Llvm.-die :: String -> a-die msg = dieDoc (text msg)--dieDoc :: Doc -> a-dieDoc msg -        = error $ renderIndent-        $    text "DDC.Core.Llvm.Convert LLVM conversion failed"-        <$$> msg------ LlvmState --------------------------------------------------------------------- | State for the LLVM conversion.-data LlvmState-        = LlvmState-        { -- Unique name generator.-          llvmStateUnique       :: Int --          -- The current platform.-        , llvmStatePlatform     :: Platform --          -- The module being converted.-        , llvmStateModule       :: C.Module () A.Name--          -- Primitives in the global environment.-        , llvmStatePrimDecls    :: Map String FunctionDecl }----- | Initial LLVM state.-llvmStateInit -        :: Platform -        -> C.Module () A.Name-        -> Map String FunctionDecl -        -> LlvmState--llvmStateInit platform mm prims-        = LlvmState-        { llvmStateUnique       = 1 -        , llvmStatePlatform     = platform-        , llvmStateModule       = mm-        , llvmStatePrimDecls    = prims }----- Unique ------------------------------------------------------------------------ | Unique name generation.-newUnique :: LlvmM Int-newUnique - = do   s       <- get-        let u   = llvmStateUnique s-        put     $ s { llvmStateUnique = u + 1 }-        return  $ u----- | Generate a new unique register variable with the specified `LlvmType`.-newUniqueVar :: Type -> LlvmM Var-newUniqueVar t- = do   u <- newUnique-        return $ Var (NameLocal ("_v" ++ show u)) t----- | Generate a new unique named register variable with the specified `LlvmType`.-newUniqueNamedVar :: String -> Type -> LlvmM Var-newUniqueNamedVar name t- = do   u <- newUnique -        return $ Var (NameLocal ("_v" ++ show u ++ "." ++ name)) t----- | Generate a new unique label.-newUniqueLabel :: String -> LlvmM Label-newUniqueLabel name- = do   u <- newUnique-        return $ Label ("l" ++ show u ++ "." ++ name)------ Platform Specific ------------------------------------------------------------- | Get the declaration of a primitive function-getPrimDeclM :: String -> LlvmM (Maybe FunctionDecl)-getPrimDeclM name- = do   prims   <- gets llvmStatePrimDecls-        return  $ Map.lookup name prims ----- | Get the size of a type on this platform, in bytes.-getBytesOfTypeM :: Type -> LlvmM Integer-getBytesOfTypeM tt- = do   platform        <- gets llvmStatePlatform-        let Just bytes  = takeBytesOfType (platformAddrBytes platform) tt-        return bytes-

@@ -89,7 +89,8 @@ nonSingleton _   = True                        --- | Use lexicographic breadth-first search on an undirected graph to produce an ordering of the vertices+-- | Use lexicographic breadth-first search on an undirected graph to produce an ordering+--   of the vertices --               lexBFS :: (Show a, Ord a) => UG a -> Class a lexBFS (UG (vertices, f)) = refine [] [vertices]@@ -112,14 +113,14 @@  -- | Transitively orient an undireted graph -----      Using the algorithm from---      "Lex-BFS and partition refinement, with applications to transitive orientation, interval ---      graph recognition and consecutive ones testing", R. McConnell et al 2000+--   Using the algorithm from+--   "Lex-BFS and partition refinement, with applications to transitive orientation, interval +--   graph recognition and consecutive ones testing", R. McConnell et al 2000 -----      In the case where the transitive orientation does not exist, it simply gives some orientation+--   In the case where the transitive orientation does not exist, it simply gives some orientation -----      note: gave up on modular decomposition, this approach has very slightly worse time---            complexity but much simpler+--   note: gave up on modular decomposition, this approach has very slightly worse time+--         complexity but much simpler --    transOrient :: (Show a, Ord a) => UG a -> DG a transOrient g@(UG (vertices, f))@@ -145,8 +146,10 @@           , all (not . null) [neighbours, nonneighbours]           = let lastused = snd cl             in  if   isBefore -                then (nonneighbours, lastused) : (neighbours,    lastused) : (split isBefore classes vertex)-                else (neighbours,    lastused) : (nonneighbours, lastused) : (split isBefore classes vertex)+                then (nonneighbours, lastused) : (neighbours,    lastused) +                        : (split isBefore classes vertex)+                else (neighbours,    lastused) : (nonneighbours, lastused) +                        : (split isBefore classes vertex)           | otherwise = cl:classes          -- Split the largest class by the last vertex in the class found by lexBFS

@@ -11,9 +11,8 @@ import DDC.Type.Predicates import DDC.Type.Collect import DDC.Type.Env                     (KindEnv)-import DDC.Core.Exp import DDC.Core.Llvm.Metadata.Graph-import DDC.Core.Llvm.LlvmM+import DDC.Core.Llvm.Convert.Base import DDC.Base.Pretty                  hiding (empty) import qualified DDC.Type.Env           as Env import qualified DDC.Core.Salt          as A@@ -72,10 +71,10 @@  -- | Generate tbaa metadata for a top-level Salt supercombinator. deriveMD-      :: (BindStruct (Exp ()))-      => String                       -- ^ Sanitized name of super-      -> Exp () A.Name                -- ^ Super to derive from-      -> LlvmM (MDSuper)              -- ^ Metadata encoding witness information            +      :: (BindStruct A.Exp A.Name)+      => String                 -- ^ Sanitized name of super+      -> A.Exp                  -- ^ Super to derive from+      -> ConvertM MDSuper       -- ^ Metadata encoding witness information              deriveMD nTop xx   = let @@ -88,13 +87,13 @@     in  foldM (buildMDTree nTop) (MDSuper emptyDict []) mdTrees  -buildMDTree :: String -> MDSuper -> Tree ANode ->  LlvmM MDSuper+buildMDTree :: String -> MDSuper -> Tree ANode -> ConvertM MDSuper buildMDTree nTop sup tree  = let tree' = anchor ARoot tree    in  bfBuild nTop tree' Nothing sup ARoot  -bfBuild :: String -> Tree ANode -> Maybe MRef -> MDSuper -> ANode -> LlvmM MDSuper+bfBuild :: String -> Tree ANode -> Maybe MRef -> MDSuper -> ANode -> ConvertM MDSuper bfBuild nTop tree parent sup node  = case parent of         Nothing        -> do name <- freshRootName nTop@@ -114,16 +113,19 @@                                        , decls   = decl:(decls s) }  -freshNodeName :: String -> Bound A.Name -> LlvmM String-freshNodeName q (UName (A.NameVar n)) = return $ q ++ "_" ++ n-freshNodeName q _                     = liftA (\i -> q ++ "_" ++ (show i)) newUnique+freshNodeName :: String -> Bound A.Name -> ConvertM String+freshNodeName q (UName nm)+    | Just n <- A.takeNameVar nm+    = return $ q ++ "_" ++ n+freshNodeName q _+    = liftA (\i -> q ++ "_" ++ (show i)) newUnique -freshRootName :: String -> LlvmM String+freshRootName :: String -> ConvertM String freshRootName qualify = liftA (\i -> qualify ++ "_ROOT_" ++ (show i)) newUnique   -- | Attach relevant metadata to instructions-annot :: (BindStruct c, Show (c A.Name))+annot :: (BindStruct (c A.Name) A.Name, Show (c A.Name))       => KindEnv A.Name        -> MDSuper        -- ^ Metadata             -> [c A.Name]     -- ^ Things to lookup for Meta data.@@ -209,7 +211,7 @@   -- | Collect region bounds-collectRegsU :: (BindStruct c) => KindEnv A.Name -> c A.Name -> [RegBound]+collectRegsU :: (BindStruct (c A.Name) A.Name) => KindEnv A.Name -> c A.Name -> [RegBound] collectRegsU kenv cc  = let isReg u = case Env.lookup u kenv of                       Just t | isRegionKind t -> True@@ -218,7 +220,7 @@   -- | Collect region bindings-collectRegsB :: (BindStruct c) => c A.Name -> [RegBound]+collectRegsB :: (BindStruct (c A.Name) A.Name) => c A.Name -> [RegBound] collectRegsB cc  = let isBindReg b           = case b of@@ -229,7 +231,7 @@      -- | Collect witness bindings together with their types (for convinience)-collectWitsB :: (BindStruct c) => c A.Name -> [WitType]+collectWitsB :: (BindStruct (c A.Name) A.Name) => c A.Name -> [WitType] collectWitsB cc  = let isBindWit b         = let t = typeOfBind b

@@ -0,0 +1,34 @@++module DDC.Core.Llvm.Runtime+        ( nameGlobalHeapTop,    varGlobalHeapTop+        , nameGlobalHeapMax,    varGlobalHeapMax+        , nameGlobalMalloc)+where+import DDC.Llvm.Syntax+import DDC.Core.Llvm.Convert.Type+import DDC.Core.Salt.Platform+++-- | Name of the global variable that points to the next byte that can+--   be allocated.+nameGlobalHeapTop :: Name+nameGlobalHeapTop = NameGlobal "_DDC__heapTop"++-- | Make the variable that points to the next byte that can be allocated.+varGlobalHeapTop :: Platform -> Var+varGlobalHeapTop pp = Var nameGlobalHeapTop (TPointer (tAddr pp))+++-- | Name of the global variable that points to the highest+--   byte that can be allocated.+nameGlobalHeapMax :: Name+nameGlobalHeapMax = NameGlobal "_DDC__heapMax"++-- | Make the variable that points to the highest byte that can be allocated.+varGlobalHeapMax :: Platform -> Var+varGlobalHeapMax pp = Var nameGlobalHeapMax (TPointer (tAddr pp))+++-- | Name of the malloc function that is used to allocate the heap.+nameGlobalMalloc  :: Name+nameGlobalMalloc  = NameGlobal "malloc"

@@ -0,0 +1,97 @@++module DDC.Llvm.Analysis.Defs+        ( Def (..)+        , takeDefOfInstr+        , defsOfBlock)+where+import DDC.Llvm.Syntax+import Data.Map                         (Map)+import qualified Data.Foldable          as Seq+import qualified Data.Map               as Map+++-- | How a variable is defined.+data Def+        -- | Variable is given a non-constant value.+        = DefVar++        -- | Variable is an alias of another variable.+        | DefAlias              Var++        -- | Variable binds some closed, constant expression.+        | DefClosedConstant     Exp+        deriving Show+++-- | Collect information about how all the local variables in this block+--   are defined.+defsOfBlock :: Block -> Map Var (Label, Def)+defsOfBlock block+        = Map.fromList+        $ [ (v, (blockLabel block, def))+                | Just (v, def) <- map (takeDefOfInstr . annotInstr)+                                $  Seq.toList $ blockInstrs block ]+++-- | If this instruction defines a variable,+--   then collect some information about it.+takeDefOfInstr :: Instr -> Maybe (Var, Def)+takeDefOfInstr instr+ = case instr of+        -- Comments+        IComment{}     +         -> Nothing++        -- Set meta instruction.+        ISet v1 x2+         | XVar v2      <- x2+         -> Just (v1, DefAlias v2)++         | isClosedConstantExp x2+         -> Just (v1, DefClosedConstant x2)++         | otherwise            +         -> Just (v1, DefVar)++        -- No operation.+        INop            -> Nothing++        -- Phi nodes+        -- Even if both branches are constant, +        -- we can't form an expression to represent this,+        -- so the result gets marked as non-constant.+        IPhi v _        -> Just (v, DefVar)++        -- Terminator Instructions+        IReturn{}       -> Nothing+        IBranch{}       -> Nothing+        IBranchIf{}     -> Nothing+        ISwitch{}       -> Nothing+        IUnreachable{}  -> Nothing++        -- Binary Operators+        IOp v _ _ _     -> Just (v, DefVar)++        -- Conversion Operators+        IConv v _ _     -> Just (v, DefVar)++        -- Get element pointer+        IGet  v _ _     -> Just (v, DefVar)++        -- Load a value from memory.+        ILoad v _       -> Just (v, DefVar)++        -- Store a value to memory.+        IStore{}        -> Nothing++        -- Comparisons+        ICmp v _ _ _    -> Just (v, DefVar)++        -- Function calls+        ICall mv _ _ _ _ _ _+         -> case mv of+                Just v  -> Just (v, DefVar)+                _       -> Nothing+++

@@ -4,49 +4,62 @@         , pprPlainL) where import DDC.Llvm.Syntax.Exp-import DDC.Llvm.Pretty.Type     ()+import DDC.Llvm.Pretty.Type             () import DDC.Base.Pretty+import Data.Text                        (Text)+import qualified Data.Text              as T  --- Exp ------------------------------------------------------------------------ instance Pretty Exp where  ppr xx   = case xx of-        XVar v   -> ppr v-        XLit l   -> ppr l-        XUndef _ -> text "undef"+        XVar v          -> ppr v+        XLit l          -> ppr l+        XUndef _        -> text "undef"+        XConv _ c x     -> parens $ ppr c <> ppr x +        XGet  _ x is    +         ->  parens $ text "getelementptr" +         <+> hcat (punctuate (text ", ") (ppr x : map (text . show) is)) + -- | Pretty print an expression without its type. pprPlainX :: Exp -> Doc pprPlainX xx  = case xx of-        XVar v   -> ppr $ nameOfVar v-        XLit l   -> pprPlainL l-        XUndef _ -> text "undef"+        XVar v          -> ppr $ nameOfVar v+        XLit l          -> pprPlainL l+        XUndef _        -> text "undef"+        XConv _ c x     -> parens $ ppr c <> ppr x +        XGet  _ x is    +         ->  parens $ text "getelementptr"+         <+> hcat (punctuate (text ", ") (ppr x : map (text . show) is)) --- Var ------------------------------------------------------------------------+ instance Pretty Var where  ppr (Var n t)  = ppr t <+> ppr n  --- Name ----------------------------------------------------------------------- instance Pretty Name where  ppr (NameGlobal str)   = text "@" <> text str  ppr (NameLocal  str)   = text "%" <> text str  --- Lit ------------------------------------------------------------------------ instance Pretty Lit where  ppr ll   = case ll of         LitInt   t i    -> ppr t <+> integer i         LitFloat{}      -> error "ddc-core-llvm.ppr[Lit]: floats aren't handled yet"-        LitNull  _      -> text "null"+        LitNull  t      -> ppr t <+> text "null"         LitUndef _      -> text "undef" +        LitString _ txEnc _   +         ->  ppr (typeOfLit ll)+         <+> text "c" <> pprString txEnc ++ -- | Pretty print a literal without its type. pprPlainL :: Lit -> Doc pprPlainL ll@@ -55,4 +68,15 @@         LitFloat{}      -> error "ddc-core-llvm.ppr[Lit]: floats aren't handled yet"         LitNull  _      -> text "null"         LitUndef _      -> text "undef"++        LitString _ txEnc _  +         -> text "c" <> pprString txEnc+++pprString :: Text -> Doc+pprString tx+ = text "\"" <> text (T.unpack tx) <> text "\""+++ 

@@ -7,6 +7,7 @@ import DDC.Llvm.Pretty.Attr             () import DDC.Llvm.Pretty.Instr            () import DDC.Base.Pretty+import Prelude                          hiding ((<$>))   instance Pretty Function where

@@ -1,9 +1,10 @@  module DDC.Llvm.Pretty.Instr where-import DDC.Llvm.Syntax.Instr+import DDC.Llvm.Syntax.Attr import DDC.Llvm.Syntax.Exp+import DDC.Llvm.Syntax.Instr import DDC.Llvm.Syntax.Metadata-import DDC.Llvm.Syntax.Attr+import DDC.Llvm.Syntax.Prim import DDC.Llvm.Pretty.Exp import DDC.Llvm.Pretty.Prim     () import DDC.Llvm.Pretty.Metadata ()@@ -77,9 +78,9 @@          IBranchIf cond labelTrue labelFalse          -> hsep [ text "br"-                 , ppr cond,      comma-                 , ppr labelTrue, comma-                 , ppr labelFalse ]+                 , ppr cond,                         comma+                 , text "label %" <> ppr labelTrue,  comma+                 , text "label %" <> ppr labelFalse ]          ISwitch x1 lDefault alts          -> text "switch"@@ -124,15 +125,22 @@                 <+> text "to"                 <+> ppr (typeOfVar vDst) +        IGet vDst xSrc os+         -> padVar vDst+                <+> equals+                <+> text "getelementptr"+                <+> (hcat $ punctuate (text ", ") $ (ppr xSrc : map ppr os))++         -- Other operations --------------------------------        IICmp vDst icond x1 x2+        ICmp vDst (ICond icond) x1 x2          -> padVar vDst                 <+> equals                 <+> text "icmp"  <+> ppr icond  <+> ppr (typeOfExp x1)                 <+> pprPlainX x1 <> comma                 <+> pprPlainX x2 -        IFCmp vDst fcond x1 x2+        ICmp vDst (FCond fcond) x1 x2          -> padVar vDst                 <+> equals                 <+> text "fcmp"  <+> ppr fcond  <+> ppr (typeOfExp x1)

@@ -78,8 +78,3 @@         ConvInttoptr    -> text "inttoptr"         ConvBitcast     -> text "bitcast" -----

@@ -66,7 +66,7 @@                 -- by default we don't print param attributes                 args    = hcat $ punctuate comma $ map ppr params -            in ppr r <> brackets (args <> varg')+            in ppr r <> parens (args <> varg')   

@@ -58,6 +58,8 @@           -- * Expressions         , Exp           (..)         , typeOfExp+        , isXVar, isXLit, isXUndef+        , isClosedConstantExp            -- * Variables         , Var           (..)@@ -70,9 +72,11 @@           -- * Literals         , Lit           (..)         , typeOfLit+        , makeLitString            -- * Primitive operators         , Op            (..)+        , Cond          (..)         , ICond         (..)         , FCond         (..)         , Conv          (..)

@@ -3,6 +3,8 @@         ( -- * Expressions           Exp   (..)         , typeOfExp+        , isXVar, isXLit, isXUndef+        , isClosedConstantExp            -- * Variables         , Var   (..)@@ -14,12 +16,28 @@            -- * Literals         , Lit   (..)-        , typeOfLit)+        , typeOfLit+        , makeLitString) where import DDC.Llvm.Syntax.Type+import DDC.Llvm.Syntax.Prim+import DDC.Llvm.Pretty.Prim             ()+import Data.Text                        (Text)+import Data.Char+import Numeric+import qualified Data.Text              as T+import qualified Data.Text.Encoding     as TE+import qualified Data.ByteString        as BS   -- Exp ------------------------------------------------------------------------+-- | Expressions can be used directly as arguments to instructions.+--+--   The expressions marked (synthetic) are safe conversions that do not+--   branch or access memory. In the real LLVM syntax we cannot represent+--   them as expressions, but they are flattened out to instructions by the+--   Clean transform.+-- data Exp          -- | Use of a variable.         = XVar   Var@@ -29,6 +47,12 @@          -- | An undefined value.         | XUndef Type++        -- | (synthetic) Cast an expression to the given type.+        | XConv  Type Conv Exp++        -- | (synthetic) Get a pointer to an element of the expression.+        | XGet   Type Exp [Exp]         deriving (Eq, Show)    @@ -40,7 +64,46 @@         XLit   lit      -> typeOfLit lit         XUndef t        -> t +        XConv  t _ _    -> t+        XGet   t _ _    -> t ++-- | Check if this expression is an `XVar`.+isXVar :: Exp -> Bool+isXVar xx+ = case xx of+        XVar{}  -> True+        _       -> False+++-- | Check if this expression is an `XLit`.+isXLit :: Exp -> Bool+isXLit xx+ = case xx of+        XLit{}  -> True+        _       -> False+++-- | Check if this expression is an `XUndef`.+isXUndef :: Exp -> Bool+isXUndef xx+ = case xx of+        XUndef{} -> True+        _        -> False+++-- | Check whether this expression is closed,+--   meaning it doesn't contain any variables that refer to the context.+isClosedConstantExp :: Exp -> Bool+isClosedConstantExp xx+ = case xx of+        XVar{}          -> False+        XLit{}          -> True+        XUndef{}        -> True+        XConv _ _ x     -> isClosedConstantExp x+        XGet  _ x1 xs   -> isClosedConstantExp x1 && all isClosedConstantExp xs++ -- Var ------------------------------------------------------------------------ -- | A variable that can be assigned to. data Var@@ -80,6 +143,16 @@         -- | A floating-point literal.         | LitFloat      Type    Double +        -- | A string literal.+        --   In LLVM these have the same type as array literals, but have a+        --   special syntax. The first component is the literal source text, +        --   while the second its the pretty printed hex encoding that +        --   the LLVM frontend accepts.+        | LitString     +        { litSource             :: Text   +        , litHexEncoded         :: Text+        , litEncodingLength     :: Int }+         -- | A null pointer literal.         --   Only applicable to pointer types         | LitNull       Type@@ -97,3 +170,50 @@         LitFloat  t _   -> t         LitNull   t     -> t         LitUndef  t     -> t++        LitString _ _ encLen +         -> TArray (fromIntegral encLen) (TInt 8)++++-- | Make a literal string from some text.+makeLitString :: Text -> Lit+makeLitString tx+ = let  (txEnc, nEncLen) = encodeText (tx `T.append` (T.pack [chr 0]))+   in   LitString tx txEnc nEncLen+++-- | Hex encode non-printable characters in this string.+--   The LLVM frontend doesn't appear to be unicode-clean, so only unoffensive+--   ASCII characters are printed verbatim. Everything is hex-encoded as UTF-8.+encodeText :: Text -> (Text, Int)+encodeText tx+ = go [] 0 tx+ where  +        go accStr accLen xx+         = case T.uncons xx of+             Nothing      +              -> (T.concat $ reverse accStr, accLen)++             Just (x, xs) +              -> let (str, len) = encodeChar x+                 in  go (str : accStr) (accLen + len) xs++        encodeChar c+         | c == ' '+          || (isAscii c && isAlphaNum c)+          || (isAscii c && isPunctuation c && c /= '"')+         = (T.pack [c], 1)++         | otherwise+         = let  bs      = TE.encodeUtf8 $ T.pack [c]+                len     = BS.length bs+           in   ( T.pack $ concatMap (\b -> "\\" ++ (padL $ showHex b "")) +                         $ BS.unpack bs+                , len)++        padL x+         | length x == 0  = "00"+         | length x == 1  = "0"  ++ x+         | otherwise      = x+

@@ -81,11 +81,9 @@         --   INop instructions are erased by the 'Clean' transform.         | INop -         -- Phi nodes --------------------------------------         | IPhi          Var     [(Exp, Label)] -         -- Terminator Instructions ------------------------         -- | Return a result.         | IReturn       (Maybe Exp)@@ -104,16 +102,16 @@         -- | Informs the optimizer that instructions after this point are unreachable.         | IUnreachable -         -- Binary Operations ------------------------------         | IOp           Var     Op      Exp     Exp -         -- Conversion Operations --------------------------         -- | Cast the variable from to the to type. This is an abstraction of three         --   cast operators in Llvm, inttoptr, prttoint and bitcast.         | IConv         Var     Conv    Exp +        -- | Get element pointer.+        | IGet          Var     Exp     [Exp]          -- Memory Access and Addressing -------------------         -- | Load a value from memory.@@ -123,13 +121,9 @@         --   First expression gives the destination pointer.         | IStore        Exp     Exp -         -- Other Operations --------------------------------        -- | Integer comparison.-        | IICmp         Var     ICond   Exp     Exp--        -- | Floating-point comparison.-        | IFCmp         Var     FCond   Exp     Exp+        -- | Comparisons+        | ICmp          Var     Cond    Exp     Exp          -- | Call a function.          --   Only NoReturn, NoUnwind and ReadNone attributes are valid.@@ -170,10 +164,10 @@         IUnreachable{}  -> Nothing         IOp var _ _ _   -> Just var         IConv var _ _   -> Just var+        IGet  var _ _   -> Just var         ILoad var _     -> Just var         IStore{}        -> Nothing-        IICmp var _ _ _ -> Just var-        IFCmp var _ _ _ -> Just var+        ICmp var _ _ _  -> Just var         ICall mvar _ _ _ _ _ _ -> mvar  

@@ -1,8 +1,7 @@  module DDC.Llvm.Syntax.Prim         ( Op    (..)-        , ICond (..)-        , FCond (..)+        , Cond  (..),   ICond (..),     FCond (..)         , Conv  (..)) where @@ -35,7 +34,14 @@         deriving (Eq, Show)  --- | Integer comparison.+-- | Conditions.+data Cond+        = ICond ICond+        | FCond FCond+        deriving (Eq, Show)+++-- | Integer conditions. data ICond         = ICondEq       -- ^ Equal (Signed and Unsigned)         | ICondNe       -- ^ Not equal (Signed and Unsigned)@@ -50,7 +56,7 @@         deriving (Eq, Show)  --- | Floating point comparison.+-- | Floating point conditions. data FCond         = FCondFalse    -- ^ Always yields false, regardless of operands.         | FCondOeq      -- ^ Both operands are not a QNAN and op1 is equal to op2.

@@ -0,0 +1,74 @@++-- | Attach calling conventions to ICall instructions.+module DDC.Llvm.Transform.Calls+        (attachCallConvs)+where+import DDC.Llvm.Syntax+++-- | Attach calling conventions to call instructions.+attachCallConvs :: Module -> Module+attachCallConvs mm+ = let  funcs'  = map (callsFunction mm) $ modFuncs mm+   in   mm { modFuncs = funcs' }+++-- | Attach calling conventions to call instructions in a function.+callsFunction :: Module -> Function -> Function+callsFunction mm fun+ = let  blocks' = map (callsBlock mm) $ funBlocks fun+   in   fun  { funBlocks = blocks' }+++-- | Attach calling conventions to call instructions in a block.+callsBlock    :: Module -> Block -> Block+callsBlock mm block+ = let  instrs' = fmap (callsInstr mm) $ blockInstrs block+   in   block { blockInstrs = instrs' }+++-- | Attach calling conventions to call instructions,+--   leaving other instructions unharmed.+callsInstr    :: Module -> AnnotInstr -> AnnotInstr+callsInstr mm ai@(AnnotInstr i annots)+ = case i of+        ICall mv ct mcc t n xs ats+         -> let Just cc2 = callConvOfName mm n+                cc'      = mergeCallConvs mcc cc2+            in  AnnotInstr (ICall mv ct (Just cc') t n xs ats)+                           annots++        _ -> ai+++-- | Lookup the calling convention for the given name.+callConvOfName :: Module -> Name -> Maybe CallConv+callConvOfName mm name+        -- Functions defined at top level can have different calling+        -- conventions.+        | NameGlobal str <- name+        , Just cc2       <- lookupCallConv str mm+        = Just cc2++        -- Unknown functions bound to variables are assumed to have+        -- the standard calling convention.+        | NameLocal _    <- name +        = Just CC_Ccc++        | otherwise      = Nothing+++-- | If there is a calling convention attached directly to an ICall+--   instruction then it must match any we get from the environment.+mergeCallConvs :: Maybe CallConv -> CallConv -> CallConv+mergeCallConvs mc cc+ = case mc of+        Nothing         -> cc++        Just cc'        +         | cc == cc'    -> cc+         | otherwise    +         -> error $ unlines+                [ "DDC.LLVM.Transform.Clean"+                , "  Not overriding exising calling convention." ]+

@@ -1,192 +0,0 @@---- | Inline `ISet` meta-instructions, drop `INop` meta-instructions,---   and propagate calling conventions from declarations to call sites.---   This should all be part of the LLVM language itself, but it isn't.-module DDC.Llvm.Transform.Clean-        (clean)-where-import DDC.Llvm.Syntax-import Data.Maybe-import Data.Map                 (Map)-import qualified Data.Map       as Map-import qualified Data.Foldable  as Seq-import qualified Data.Sequence  as Seq----- | Clean a module.-clean :: Module -> Module-clean mm- = let  binds           = Map.empty-   in   mm { modFuncs   = map (cleanFunction mm binds) -                        $ modFuncs mm }----- | Clean a function.-cleanFunction-        :: Module-        -> Map Var Exp          -- ^ Map of variables to their values.-        -> Function -> Function--cleanFunction mm binds fun- = fun { funBlocks      = cleanBlocks mm binds Map.empty [] -                        $ funBlocks fun }----- | Clean set instructions in some blocks.-cleanBlocks -        :: Module-        -> Map Var Exp          -- ^ Map of variables to their values.-        -> Map Var Label        -- ^ Map of variables to the label -                                --    of the block they were defined in.-        -> [Block] -        -> [Block] -        -> [Block]--cleanBlocks _mm _binds _defs acc []-        = reverse acc--cleanBlocks mm binds defs acc (Block label instrs : bs) - = let  (binds', defs', instrs2) -                = cleanInstrs mm label binds defs [] -                $ Seq.toList instrs--        instrs' = Seq.fromList instrs2-        block'  = Block label instrs'--   in   cleanBlocks mm binds' defs' (block' : acc) bs----- | Clean set instructions in some instructions.-cleanInstrs -        :: Module-        -> Label                -- ^ Label of the current block.-        -> Map Var Exp          -- ^ Map of variables to their values.-        -> Map Var Label        -- ^ Map of variables to the label-                                --    of the block they were defined in.-        -> [AnnotInstr]-        -> [AnnotInstr] -        -> (Map Var Exp, Map Var Label, [AnnotInstr])--cleanInstrs _mm _label binds defs acc []-        = (binds, defs, reverse acc)--cleanInstrs mm label binds defs acc (ins@(AnnotInstr i annots) : instrs)-  = let next binds' defs' acc' -                = cleanInstrs mm label binds' defs' acc' instrs-        -        reAnnot i' = annotWith i' annots--        sub xx  -         = case xx of-                XVar v-                  | Just x' <- Map.lookup v binds-                  -> sub x'-                _ -> xx--    in case i of-        IComment{}              -         -> next binds defs (ins : acc)        --        -- The LLVM compiler doesn't support ISet instructions,-        --  so we inline them into their use sites.-        ISet v x                -         -> let binds'  = Map.insert v x binds-            in  next binds' defs acc--        -- The LLVM compiler doesn't support INop instructions,-        --  so we drop them out.         -        INop-         -> next binds defs acc--        -- At phi nodes, drop out joins of the 'undef' value.-        --  The converter adds these in rigtht before calling 'abort',-        --  so we can never arrive from one of those blocks.-        IPhi v xls-         -> let -                -- Don't merge undef expressions in phi nodes.-                keepPair (XUndef _)  = False-                keepPair _           = True--                i'      = IPhi v [(sub x, l) -                                        | (x, l) <- xls -                                        , keepPair (sub x) ]--                defs'   = Map.insert v label defs-            in  next binds defs' $ (reAnnot i') : acc---        IReturn Nothing-         -> next binds defs $ ins                                       : acc--        IReturn (Just x)-         -> next binds defs $ (reAnnot $ IReturn (Just (sub x)))        : acc--        IBranch{}-         -> next binds defs $ ins                                       : acc--        IBranchIf x l1 l2-         -> next binds defs $ (reAnnot $ IBranchIf (sub x) l1 l2)       : acc--        ISwitch x def alts-         -> next binds defs $ (reAnnot $ ISwitch   (sub x) def alts)    : acc--        IUnreachable-         -> next binds defs $ ins                                       : acc--        IOp    v op x1 x2-         |  defs'        <- Map.insert v label defs-         -> next binds defs' $ (reAnnot $ IOp   v op (sub x1) (sub x2))  : acc--        IConv  v c x-         |  defs'        <- Map.insert v label defs-         -> next binds defs' $ (reAnnot $ IConv v c (sub x))             : acc--        ILoad  v x-         |  defs'        <- Map.insert v label defs-         -> next binds defs' $ (reAnnot $ ILoad v   (sub x))             : acc--        IStore x1 x2-         -> next binds defs  $ (reAnnot $ IStore    (sub x1) (sub x2))   : acc--        IICmp  v c x1 x2-         |  defs'        <- Map.insert v label defs-         -> next binds defs' $ (reAnnot $ IICmp v c (sub x1) (sub x2))   : acc--        IFCmp  v c x1 x2-         |  defs'        <- Map.insert v label defs-         -> next binds defs' $ (reAnnot $ IFCmp v c (sub x1) (sub x2))   : acc--        ICall  (Just v) ct mcc t n xs ats-         |  defs'        <- Map.insert v label defs-         -> let NameGlobal str  = n-                cc2             = fromMaybe (error $ "ddc-core-llvm: no forward decl for " ++ str)-                                $ lookupCallConv str mm-                cc'             = mergeCallConvs mcc cc2-                -            in  next binds defs' -                        $ (reAnnot $ ICall (Just v) ct (Just cc') t n (map sub xs) ats) -                        : acc--        ICall  Nothing ct mcc t n xs ats-         -> let NameGlobal str  = n-                cc2             = fromMaybe (error $ "ddc-core-llvm: no forward decl for " ++ str)-                                $ lookupCallConv str mm-                cc'             = mergeCallConvs mcc cc2-            in  next binds defs -                        $ (reAnnot $ ICall Nothing  ct (Just cc') t n (map sub xs) ats) -                        : acc----- | If there is a calling convention attached directly to an ICall---   instruction then it must match any we get from the environment.-mergeCallConvs :: Maybe CallConv -> CallConv -> CallConv-mergeCallConvs mc cc- = case mc of-        Nothing         -> cc-        Just cc'        -         | cc == cc'    -> cc-         | otherwise    -         -> error $ unlines-                  [ "DDC.LLVM.Transform.Clean"-                  , "  Not overriding exising calling convention." ]-

@@ -0,0 +1,180 @@++-- | Flatten out the extended operators in our expression type to instructions+--   that the LLVM compiler will accept directly.+--+--   The LLVM expresion language is anemic by design. During code generation+--   we use a fatter language, but now need to flatten out the extra operators+--   into plain LLVM instructions.+--+--   This transform is kept separate from the 'Simpl' as it the input and+--   output programs are in different (sub) languages.+--+module DDC.Llvm.Transform.Flatten+        (flatten)+where+import DDC.Llvm.Syntax+import DDC.Control.Monad.Check+import Data.Sequence            (Seq, (|>), (><))+import Control.Monad+import qualified Data.Sequence  as Seq+import qualified Data.Foldable  as Seq+++-- | Flatten expressions in a module.+flatten :: Module -> Module+flatten mm+ = let  Right funcs'    +                = evalCheck 0 +                $ mapM flattenFunction $ modFuncs mm+   in   mm { modFuncs = funcs' }+++-- | Flatten expressions in a function.+flattenFunction :: Function -> FlattenM Function+flattenFunction fun+ = do   blocks' <- mapM flattenBlock $ funBlocks fun+        return  $ fun { funBlocks = blocks' }+++-- | Flatten expressions in a single block.+flattenBlock    :: Block   -> FlattenM Block+flattenBlock block+ = do   instrs' <- flattenInstrs Seq.empty +                $  Seq.toList $ blockInstrs block+        return  $ block { blockInstrs = Seq.fromList instrs' }+++-- | Flatten a list of instructions.+flattenInstrs   +        :: Seq AnnotInstr       -- ^ Accumulated instructions of result.+        -> [AnnotInstr]         -- ^ Instructions still to flatten.+        -> FlattenM [AnnotInstr]++flattenInstrs acc [] + = return $ Seq.toList acc++flattenInstrs acc (AnnotInstr i annots : is)+ = let  +        next acc'+         = flattenInstrs acc' is++        reannot i'+         = annotWith i' annots++   in case i of++         -- Comments+         IComment{}+          ->    next $ acc |> reannot i++         -- Set meta-instructions.+         ISet v x1+          -> do (is1, x1')     <- flattenX x1+                next $ (acc >< is1) |> (reannot $ ISet v x1')++         -- Preserve nops, for the sake of just doing one thing at a time.+         -- These can be eliminated with the LLVM simplifier.+         INop +          ->    next $ acc |> reannot i++         -- Phi nodes+         IPhi{}+          ->    next $ acc |> reannot i++         -- Terminator instructions+         IReturn{}+          ->    next $ acc |> reannot i++         IBranch{}+          ->    next $ acc |> reannot i++         IBranchIf x1 l1 l2+          -> do (is1, x1')      <- flattenX x1+                next $ (acc >< is1)  |> (reannot $ IBranchIf x1' l1 l2)++         ISwitch   x1 def alts+          -> do (is1, x1')      <- flattenX x1+                next $ (acc >< is1)  |> (reannot $ ISwitch x1' def alts)++         IUnreachable+          ->    next (acc |> (reannot i))++         -- Operators+         IOp v op x1 x2+          -> do (is1, x1')      <- flattenX x1+                (is2, x2')      <- flattenX x2+                next $ (acc >< is1 >< is2) |> (reannot $ IOp v op x1' x2')++         -- Conversions+         IConv v c x1+          -> do (is1, x1')      <- flattenX x1+                next $ (acc >< is1)  |> (reannot $ IConv v c x1')++         -- Get pointer+         IGet  v x1 os+          -> do (is1, x1')      <- flattenX x1+                next $ (acc >< is1)  |> (reannot $ IGet  v x1' os)++         -- Memory access+         ILoad  v x1+          -> do (is1, x1')      <- flattenX x1+                next $ (acc >< is1)  |> (reannot $ ILoad  v x1')++         IStore x1 x2+          -> do (is1, x1')      <- flattenX x1+                (is2, x2')      <- flattenX x2+                next $ (acc >< is1 >< is2) |> (reannot $ IStore x1' x2')++         -- Comparisons+         ICmp v c x1 x2+          -> do (is1, x1')      <- flattenX x1+                (is2, x2')      <- flattenX x2+                next $ (acc >< is1 >< is2) |> (reannot $ ICmp v c x1' x2')++         -- Function calls+         ICall mv ct mcc t n xs ats        +          -> do (iss, xs')      <- fmap unzip $ mapM flattenX xs+                let is'         =  join $ Seq.fromList iss+                next $  (acc >< is') +                     |> (reannot $ ICall mv ct mcc t n xs' ats)+++---------------------------------------------------------------------------------------------------+-- | Given an extended LLVM expression, strip off our extended XConv and XGet+--   operators and turn them into new instructions. The LLVM compiler itself+--   doesn't accept XConv or XGet in an expression position.+flattenX :: Exp -> FlattenM (Seq AnnotInstr, Exp)+flattenX xx+ = case xx of+        XConv t c x+         -> do  (is', x') <- flattenX x+                v         <- newUniqueVar t+                return    (is' |> (annotNil $ IConv v c x'), XVar v)++        XGet  t x os+         -> do  (is', x') <- flattenX x+                v         <- newUniqueVar t+                return    (is' |> (annotNil $ IGet v x' os), XVar v)++        _ ->    return (Seq.empty, xx)++++-- teh monads -------------------------------------------------------------------------------------+type FlattenM a = CheckM Int String a+++-- | Unique name generation.+newUnique :: FlattenM Int+newUnique + = do   s       <- get+        put     $ s + 1+        return  $ s+++-- | Generate a new unique register variable with the specified `LlvmType`.+newUniqueVar :: Type -> FlattenM Var+newUniqueVar t+ = do   u <- newUnique+        return $ Var (NameLocal ("_c" ++ show u)) t+

@@ -1,88 +0,0 @@--module DDC.Llvm.Transform.LinkPhi-        (linkPhi)-where-import DDC.Llvm.Analysis.Parents-import DDC.Llvm.Syntax-import DDC.Llvm.Graph-import qualified Data.Sequence  as Seq----- | Link Phi instructions in a module.------   For Phi instructions, the Salt->Llvm converter just fills in the source---   block label of each variable to be merged with 'undef'. We need to add---   the real block label of the in-edge that defines each variable.------   We build a graph of each block, work out the in-edges due to branches,---   and fill in the real block labels by back tracing the in-edges until we---   find the node that defines each variable.----linkPhi :: Module -> Module-linkPhi mm- = mm { modFuncs = map (linkPhiFunction) $ modFuncs mm }----- | Link Phi instructions in a function.-linkPhiFunction :: Function -> Function-linkPhiFunction fun- = fun  { funBlocks -                = let Just graph = graphOfBlocks () (funBlocks fun) -                  in  blocksOfGraph-                        $ linkPhiGraph graph }----- | Link Phi instructions in a block graph.-linkPhiGraph :: Graph () -> Graph Parents-linkPhiGraph graph- = let  graph'  = mapAnnotsOfGraph snd -                $ annotParentsOfGraph graph-   in   mapNodesOfGraph (linkPhiNode graph') graph'----- | Link Phi instructions in a node.-linkPhiNode :: Graph Parents -> Node Parents -> Node Parents-linkPhiNode graph node@(Node label instrs parents)- | (Seq.viewl -> instr Seq.:< rest)       <- instrs- = case instr of-        -- If a block has a Phi instruction then it always comes first.-        AnnotInstr IPhi{} _-         -> let Just instr'  = linkPhiInstr graph label instr-            in  Node label (instr' Seq.<| rest) parents--        _ -> node-- | otherwise- = node----- | Link the block labels in this Phi instruction.-linkPhiInstr -        :: Graph Parents  -- ^ Block graph of the whole function body.-        -> Label          -- ^ Label of the block this instruction is in.-        -> AnnotInstr     -- ^ The Phi instruction to link.-        -> Maybe AnnotInstr--linkPhiInstr graph lNode (AnnotInstr (IPhi vDst xls) meta)- = Just $ AnnotInstr (IPhi vDst xls') meta- where  -        -- Link all the labels in the Phi instruction.-        xls'    = [(x, linkLabel x lMerge) | (x, lMerge) <- xls]--        -- Find the in-edge that defines this variable.-        --  We use 'lineageOfVar' to get the list of in-edges all the-        --  way back to the use-site. The parent node of the current one-        --  is then second in the list.-        linkLabel (XVar var) lMerge-         = case lineageOfVar graph var lNode of-                Just (_ : lParent : _)  -> lParent-                _                       -> lMerge--        -- If we can't find the definition then just return the-        -- original label.-        linkLabel _ lMerge              =  lMerge---linkPhiInstr _graph _ _-        = Nothing-

@@ -0,0 +1,263 @@++-- | LLVM program simplifier.+--+--   The LLVM compiler itself already contains a metric crapton of transforms+--   that we don't want to re-implement here. However, these simple things+--   are useful when normalising the code emitted by the code generator, +--   so that the LLVM compiler will actually accept it.+--   +module DDC.Llvm.Transform.Simpl+        ( simpl+        , Config (..)+        , configZero)+where+import DDC.Llvm.Syntax+import DDC.Llvm.Analysis.Defs+import DDC.Control.Monad.Check+import Data.Sequence            (Seq, (|>))+import Data.Map                 (Map)+import qualified Data.Map       as Map+import qualified Data.Foldable  as Seq+import qualified Data.Sequence  as Seq+++---------------------------------------------------------------------------------------------------+-- | Simplifier config.+data Config+        = Config+        { -- | Drop NOP instructions.+          configDropNops         :: Bool++          -- | Inline simple v1 v2 bindings.+        , configSimplAlias      :: Bool++          -- | Inline simple v1 const bindings.+          --+          --   NOTE: Inlining constants into phi nodes before the 'from' labels for+          --         each in-edge are filled will lose information and render the+          --         program uncompilable.+        , configSimplConst      :: Bool ++          -- Squash out joins of 'undef' values in phi nodes.+          --   The code generator uses 'undef' as the result of an expression+          --   that calls 'abort', but we don't want that propagated into +          --   phi nodes.+        , configSquashUndef     :: Bool }+++-- | Config with all transforms disabled.+configZero :: Config+configZero+        = Config+        { configDropNops        = False+        , configSimplAlias      = False+        , configSimplConst      = False +        , configSquashUndef     = False }+++---------------------------------------------------------------------------------------------------+-- | Simplify a module.+simpl :: Config -> Module -> Module+simpl config mm+ = let  Right funcs'    +                = evalCheck ()+                $ mapM (simplFunction config) $ modFuncs mm+   in   mm { modFuncs = funcs' }+++-- | Simplify the body of a function.+simplFunction :: Config -> Function -> SimplM Function+simplFunction config fun+ = do   +        -- Build a map of how all the variables in this function are defined.+        let defs = Map.unions +                 $ map defsOfBlock $ funBlocks fun++        -- Simplify each block in turn.+        blocks'  <- mapM (simplBlock config defs) +                 $ funBlocks fun++        return   $ fun { funBlocks = blocks' }+++-- | Simplify a single block.+simplBlock    +        :: Config               -- ^ Simplifier configuration.+        -> Map Var (Label, Def) -- ^ How each variable in the function is defined.+        -> Block                -- ^ Block to simplify.+        -> SimplM Block++simplBlock config defs block+ = do   instrs' <- simplInstrs config defs Seq.empty +                $  Seq.toList $ blockInstrs block+        return  $ block { blockInstrs = Seq.fromList instrs' }+++-- | Simplify a list of instructions.+simplInstrs+        :: Config               -- ^ Simplifier configuration.+        -> Map Var (Label, Def) -- ^ How each variable in the function is defined.+        -> Seq AnnotInstr       -- ^ Accumulated instructions of result.+        -> [AnnotInstr]         -- ^ Instructions still to simplify.+        -> SimplM [AnnotInstr]++simplInstrs _config _defs acc []+ = return $ Seq.toList acc++simplInstrs config defs acc (AnnotInstr i annots : is)+ = let+        -- Move to the next instruction in the sequence.+        next acc'+         = simplInstrs config defs acc' is++        -- Attach the annotation back to this instruction.+        reannot i'+         = annotWith i' annots++        -- Use the defs map to try to substitue this variable for +        -- something even better.+        subst xx0+         = go (0 :: Int) xx0+         where +                go !n _xx+                 -- Bail out to avoid diverging when there is a loop in the definitions.+                 -- This should never happen in a sane, well formed program.+                 |  n > 1000000+                 = throw ErrorSimplAliasLoop++                go !n xx+                 = case xx of+                        XVar v+                         -> case Map.lookup v defs of+                                Just (_, DefAlias v')+                                 | configSimplAlias config+                                 -> go (n + 1) (XVar v')++                                Just (_, DefClosedConstant xx')+                                 | configSimplConst config+                                 -> return xx'++                                _ -> return xx+                        _ -> return xx++   in case i of++        -- Comments+        IComment{}+         ->     next $ acc |> reannot i++        -- Set meta-instructions.+        ISet v1 x2+         -- Simple aliases being substituted out.+         | XVar _v2     <- x2+         , configSimplAlias config+         ->     next acc++         -- Closed constants being substituted out.+         | isClosedConstantExp x2+         , configSimplConst config+         ->     next acc++         | otherwise+         -> do  x2'     <- subst x2+                next $ acc |> reannot (ISet v1 x2')++        -- Drop nops if we were asked to.+        INop+         | configDropNops config+         ->     next acc++         | otherwise+         ->     next $ acc |> reannot i++        -- Phi nodes.+        IPhi v xls+         -> do  +                -- Substitute into expressions.+                xs_subst       <- mapM subst $ map fst xls+                let ls_subst   =  map snd xls++                -- Squash out joins of 'undef' values in phi nodes.+                --   The code generator uses 'undef' as the result of an expression+                --   that calls 'abort', but we don't want that propagated into +                --   phi nodes.+                let xls_squash +                        | configSquashUndef config+                        = [ (x, l) | (x, l) <- zip xs_subst ls_subst+                                    , not $ isXUndef x]    ++                        | otherwise+                        = zip xs_subst ls_subst++                next $ acc |> reannot (IPhi v xls_squash)++        -- Terminator instructions+        IReturn mx+         -> do  mx'     <- case mx of+                                Nothing -> return Nothing+                                Just x  -> fmap Just $ subst x++                next $ acc |> reannot (IReturn mx')++        IBranch{}+         ->     next $ acc |> reannot i++        IBranchIf x1 l2 l3+         -> do  x1'     <- subst x1+                next $ acc |> reannot (IBranchIf x1' l2 l3)++        ISwitch x1 def alts+         -> do  x1'     <- subst x1+                next $ acc |> reannot (ISwitch   x1' def alts)++        IUnreachable+         ->     next $ acc |> reannot i++        -- Operators+        IOp v op x1 x2+         -> do  x1'     <- subst x1+                x2'     <- subst x2+                next $ acc |> reannot (IOp   v op x1' x2')++        -- Conversions+        IConv v c x1+         -> do  x1'     <- subst x1+                next $ acc |> reannot (IConv v c x1')++        -- Get pointer+        IGet  v x1 os+         -> do  x1'     <- subst x1+                next $ acc |> reannot (IGet  v x1' os)++        -- Memory instructions+        ILoad v x1+         -> do  x1'     <- subst x1+                next $ acc |> reannot (ILoad v x1')++        IStore x1 x2+         -> do  x1'     <- subst x1+                x2'     <- subst x2+                next $ acc |> reannot (IStore x1' x2')++        -- Comparisons+        ICmp v c x1 x2+         -> do  x1'     <- subst x1+                x2'     <- subst x2+                next $ acc |> reannot (ICmp  v c x1' x2')++        -- Calls+        ICall mv cc mcc t n xs ats+         -> do  xs'     <- mapM subst xs+                next $ acc |> reannot (ICall mv cc mcc t n xs' ats)+++-- teh monads -------------------------------------------------------------------------------------+type SimplM a = CheckM () ErrorSimpl a+++-- | Things that can go wrong during simplification.+data ErrorSimpl+        -- | Substitution for v1 = v2 didn't complete after a sane+        --   number of iterations. There might be a loop in the definitions.+        = ErrorSimplAliasLoop+

@@ -1,5 +1,5 @@ Name:           ddc-core-llvm-Version:        0.4.1.3+Version:        0.4.2.1 License:        MIT License-file:   LICENSE Author:         The Disciplined Disciple Compiler Strike Force@@ -14,39 +14,50 @@  Library   Build-Depends: -        base            >= 4.6 && < 4.8,-        array           >= 0.4 && < 0.6,+        base            >= 4.6  && < 4.9,+        array           >= 0.4  && < 0.6,+        bytestring      >= 0.10 && < 0.11,         containers      == 0.5.*,+        text            >= 1.0  && < 1.3,         transformers    == 0.4.*,-        mtl             == 2.2.*,-        ddc-base        == 0.4.1.*,-        ddc-core        == 0.4.1.*,-        ddc-core-simpl  == 0.4.1.*,-        ddc-core-salt   == 0.4.1.*+        mtl             == 2.2.1.*,+        ddc-base        == 0.4.2.*,+        ddc-core        == 0.4.2.*,+        ddc-core-simpl  == 0.4.2.*,+        ddc-core-salt   == 0.4.2.*    Exposed-modules:         DDC.Core.Llvm.Metadata.Graph         DDC.Core.Llvm.Metadata.Tbaa         DDC.Core.Llvm.Convert-                  +        DDC.Core.Llvm.Runtime+         DDC.Llvm.Analysis.Children+        DDC.Llvm.Analysis.Defs         DDC.Llvm.Analysis.Parents -        DDC.Llvm.Transform.Clean-        DDC.Llvm.Transform.LinkPhi+        DDC.Llvm.Transform.Calls+        DDC.Llvm.Transform.Flatten+        DDC.Llvm.Transform.Simpl +        DDC.Llvm.Graph         DDC.Llvm.Pretty         DDC.Llvm.Syntax-        DDC.Llvm.Graph    Other-modules:-        DDC.Core.Llvm.Convert.Atom-        DDC.Core.Llvm.Convert.Erase+        DDC.Core.Llvm.Convert.Exp.Atom+        DDC.Core.Llvm.Convert.Exp.Case+        DDC.Core.Llvm.Convert.Exp.PrimArith+        DDC.Core.Llvm.Convert.Exp.PrimCall+        DDC.Core.Llvm.Convert.Exp.PrimCast+        DDC.Core.Llvm.Convert.Exp.PrimStore++        DDC.Core.Llvm.Convert.Base+        DDC.Core.Llvm.Convert.Context+        DDC.Core.Llvm.Convert.Error         DDC.Core.Llvm.Convert.Exp-        DDC.Core.Llvm.Convert.Prim         DDC.Core.Llvm.Convert.Super         DDC.Core.Llvm.Convert.Type-        DDC.Core.Llvm.LlvmM          DDC.Llvm.Pretty.Attr         DDC.Llvm.Pretty.Exp@@ -83,5 +94,4 @@         FlexibleContexts         ViewPatterns         TupleSections--        +        BangPatterns