diff --git a/DDC/Core/Llvm/Convert.hs b/DDC/Core/Llvm/Convert.hs --- a/DDC/Core/Llvm/Convert.hs +++ b/DDC/Core/Llvm/Convert.hs @@ -12,9 +12,9 @@ import DDC.Core.Llvm.Convert.Base import DDC.Core.Llvm.Runtime import DDC.Core.Salt.Platform -import DDC.Core.Exp.Annot.Compounds +import DDC.Core.Exp.Annot as A import DDC.Llvm.Syntax -import DDC.Control.Monad.Check +import DDC.Control.Check import qualified Control.Monad.State.Strict as State import Control.Monad import Data.Map (Map) diff --git a/DDC/Core/Llvm/Convert/Base.hs b/DDC/Core/Llvm/Convert/Base.hs --- a/DDC/Core/Llvm/Convert/Base.hs +++ b/DDC/Core/Llvm/Convert/Base.hs @@ -16,7 +16,7 @@ where import DDC.Core.Llvm.Convert.Error import DDC.Llvm.Syntax -import DDC.Control.Monad.Check +import DDC.Control.Check import Data.Map (Map) import qualified Data.Map as Map diff --git a/DDC/Core/Llvm/Convert/Error.hs b/DDC/Core/Llvm/Convert/Error.hs --- a/DDC/Core/Llvm/Convert/Error.hs +++ b/DDC/Core/Llvm/Convert/Error.hs @@ -4,8 +4,8 @@ where import DDC.Core.Module import DDC.Core.Exp -import DDC.Base.Pretty -import DDC.Core.Exp.Generic.Pretty () +import DDC.Core.Exp.Generic () +import DDC.Data.Pretty import Data.Maybe import qualified DDC.Core.Salt as A diff --git a/DDC/Core/Llvm/Convert/Exp.hs b/DDC/Core/Llvm/Convert/Exp.hs --- a/DDC/Core/Llvm/Convert/Exp.hs +++ b/DDC/Core/Llvm/Convert/Exp.hs @@ -1,4 +1,9 @@ +-- In GHC 8 we need to turn of the pattern match checker because the new algorithm +-- runs out of stack space when checking this module. +-- https://ghc.haskell.org/trac/ghc/ticket/11822 +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} + module DDC.Core.Llvm.Convert.Exp ( Context (..) , convertBody @@ -14,7 +19,6 @@ import DDC.Core.Llvm.Convert.Type import DDC.Core.Llvm.Convert.Base import DDC.Llvm.Syntax -import DDC.Core.Exp.Generic.Compounds import Control.Applicative import Data.Sequence (Seq, (|>), (><)) import qualified DDC.Core.Salt as A @@ -49,10 +53,10 @@ -- We must be at the top-level of the function. A.XApp{} | ExpTop{} <- ectx - , Just (p, as) <- takeXPrimApps xx + , Just (p, as) <- A.takeXPrimApps xx , A.PrimControl A.PrimControlReturn <- p , [A.RType{}, A.RExp (A.XCon dc)] <- as - , Just (A.NamePrimLit A.PrimLitVoid) <- takeNameOfDaCon dc + , Just (A.NamePrimLit A.PrimLitVoid) <- A.takeNameOfDaCon dc -> return $ blocks |> Block label (instrs |> (annotNil $ IReturn Nothing)) @@ -62,7 +66,7 @@ -- We must be at the top-level of the function. A.XApp{} | ExpTop{} <- ectx - , Just (p, as) <- takeXPrimApps xx + , Just (p, as) <- A.takeXPrimApps xx , A.PrimControl A.PrimControlReturn <- p , [A.RType t, A.RExp x2] <- as , isVoidT t @@ -75,7 +79,7 @@ -- We must be at the top-level of the function. A.XApp{} | ExpTop{} <- ectx - , Just (p, as) <- takeXPrimApps xx + , Just (p, as) <- A.takeXPrimApps xx , A.PrimControl A.PrimControlReturn <- p , [A.RType t, A.RExp x] <- as -> do t' <- convertType pp kenv t @@ -88,7 +92,7 @@ -- Fail and abort the program. -- Allow this inside an expression as well as from the top level. A.XApp{} - | Just (p, as) <- takeXPrimApps xx + | Just (p, as) <- A.takeXPrimApps xx , A.PrimControl A.PrimControlFail <- p , [A.RType _tResult] <- as -> let @@ -113,12 +117,12 @@ -- Tailcall a function. -- We must be at the top-level of the function. A.XApp{} - | Just (p, args) <- takeXPrimApps xx + | Just (p, args) <- A.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 + , (xFun, _xsTys) <- A.splitXApps xFunTys , Just mFun <- takeGlobalV ctx xFun , Just msArgs <- sequence $ map (mconvArg ctx) xsArgs -> do @@ -147,7 +151,7 @@ -- Assignment ------------------------------------ -- Read from a pointer, with integrated bounds check. A.XLet (A.LLet (C.BName nDst _) x1) x2 - | Just (p, as) <- takeXPrimApps x1 + | Just (p, as) <- A.takeXPrimApps x1 , A.PrimStore A.PrimStorePeekBounded <- p , A.RType{} : A.RType tDst : args <- as , Just [mPtr, mOffset, mLength] <- atomsR args @@ -198,7 +202,7 @@ -- Write to a pointer, with integrated bounds check. A.XLet (A.LLet _ x1) x2 - | Just (p, as) <- takeXPrimApps x1 + | Just (p, as) <- A.takeXPrimApps x1 , A.PrimStore A.PrimStorePokeBounded <- p , A.RType{} : A.RType tVal : args <- as , Just [mPtr, mOffset, mLength, mVal] <- atomsR args @@ -298,7 +302,7 @@ -- 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 + | (xF, asArgs) <- A.splitXApps x1 , A.XVar (C.UName nSuper) <- xF , tsArgs <- [t | A.RType t <- asArgs] , length tsArgs > 0 @@ -383,7 +387,7 @@ -- Primitive operators. A.XApp{} - | Just (p, args) <- takeXPrimApps xx + | Just (p, args) <- A.takeXPrimApps xx , mDst <- takeNonVoidVarOfContext ectx , Just go <- foldl (<|>) empty [ convPrimCall ctx mDst p args @@ -393,7 +397,7 @@ -> go -- Call to top-level super. - | (xFun@(A.XVar u), xsArgs) <- splitXApps xx + | (xFun@(A.XVar u), xsArgs) <- A.splitXApps xx , Just tSuper <- Env.lookup u tenv , Just msArgs_value <- sequence $ map (mconvArg ctx) $ eraseTypeWitArgs xsArgs , Just mFun <- takeGlobalV ctx xFun diff --git a/DDC/Core/Llvm/Convert/Exp/Atom.hs b/DDC/Core/Llvm/Convert/Exp/Atom.hs --- a/DDC/Core/Llvm/Convert/Exp/Atom.hs +++ b/DDC/Core/Llvm/Convert/Exp/Atom.hs @@ -13,8 +13,8 @@ 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 DDC.Control.Check +import DDC.Data.Pretty import Control.Monad import Data.Maybe import qualified DDC.Type.Env as Env @@ -24,7 +24,7 @@ import qualified DDC.Core.Exp as C import qualified Data.Map as Map import qualified Data.List as List - +import qualified Data.Char as Char -- Arguments ------------------------------------------------------------------ -- | Convert a function argument expression @@ -112,6 +112,12 @@ t' <- convertType pp kenv t return $ XLit (LitFloat t' val) + -- Literal character + A.PrimLitChar c + -> Just $ do + return $ XLit (LitInt (TInt 32) (fromIntegral $ Char.ord c)) + + -- A text literal. A.PrimLitTextLit tx -> Just $ do @@ -147,30 +153,25 @@ -- 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 +bindLocalV :: Context -> A.Name -> A.Type -> ConvertM (Context, Var) + +bindLocalV ctx name@(A.NameVar 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 ctx name@(A.NameExt (A.NameVar str1) _str2) t + = do t' <- convertType (contextPlatform ctx) (contextKindEnv ctx) t + let str' = A.sanitizeName str1 + v <- newUniqueNamedVar str' t' + let ctx' = extendTypeEnv (C.BName name t) ctx + let ctx'' = ctx' { contextNames = Map.insert name v (contextNames ctx') } + return (ctx'', v) -bindLocalV _ _ _ +bindLocalV _ _ _ = error "ddc-core-llvm.bindLocalV: not a regular name." @@ -243,8 +244,13 @@ let mExport = lookup nSuper (C.moduleExportValues mm) -- Convert local name to sanitized LLVM name. - let Just str = liftM renderPlain + let result = liftM renderPlain $ A.seaNameOfSuper mImport mExport nSuper + + let str = case result of + Just str' -> str' + Nothing -> error "ddc-core-llvm: takeGlobalV" + t' <- convertType pp kenv t return $ Var (NameGlobal str) t' diff --git a/DDC/Core/Llvm/Convert/Exp/Case.hs b/DDC/Core/Llvm/Convert/Exp/Case.hs --- a/DDC/Core/Llvm/Convert/Exp/Case.hs +++ b/DDC/Core/Llvm/Convert/Exp/Case.hs @@ -7,7 +7,6 @@ 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 @@ -139,7 +138,7 @@ return $ AltDefault label blocks A.AAlt (A.PData dc []) x - | Just n <- takeNameOfDaCon dc + | Just n <- A.takeNameOfDaCon dc , Just lit <- convPatName pp n -> do label <- newUniqueLabel "alt" blocks <- convBodyM ctx ectx Seq.empty label Seq.empty x diff --git a/DDC/Core/Llvm/Convert/Super.hs b/DDC/Core/Llvm/Convert/Super.hs --- a/DDC/Core/Llvm/Convert/Super.hs +++ b/DDC/Core/Llvm/Convert/Super.hs @@ -9,12 +9,11 @@ import DDC.Core.Llvm.Convert.Base import DDC.Llvm.Syntax import DDC.Core.Salt.Platform -import DDC.Type.Predicates -import DDC.Base.Pretty hiding (align) +import DDC.Type.Exp.Simple.Predicates +import DDC.Data.Pretty hiding (align) 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 Data.Set as Set diff --git a/DDC/Core/Llvm/Convert/Type.hs b/DDC/Core/Llvm/Convert/Type.hs --- a/DDC/Core/Llvm/Convert/Type.hs +++ b/DDC/Core/Llvm/Convert/Type.hs @@ -25,9 +25,9 @@ import DDC.Llvm.Syntax.Attr import DDC.Core.Salt.Platform import DDC.Type.Env -import DDC.Type.Compounds -import DDC.Type.Predicates -import DDC.Base.Pretty +import DDC.Type.Exp.Simple.Compounds +import DDC.Type.Exp.Simple.Predicates +import DDC.Data.Pretty import qualified DDC.Core.Salt as A import qualified DDC.Core.Salt.Name as A import qualified DDC.Core.Salt.Convert as A @@ -126,8 +126,8 @@ importedFunctionDeclOfType :: Platform -> KindEnv A.Name - -> C.ImportValue A.Name - -> Maybe (C.ExportSource A.Name) + -> C.ImportValue A.Name (C.Type A.Name) + -> Maybe (C.ExportSource A.Name (C.Type A.Name)) -> A.Name -> C.Type A.Name -> Maybe (ConvertM FunctionDecl) @@ -163,9 +163,6 @@ , declParamListType = FixedArgs , declParams = map mkParam tsArgs , declAlign = AlignBytes (platformAlignBytes pp) } - -importedFunctionDeclOfType _ _ _ _ _ _ - = Nothing -- TyCon ---------------------------------------------------------------------- diff --git a/DDC/Core/Llvm/Metadata/Graph.hs b/DDC/Core/Llvm/Metadata/Graph.hs --- a/DDC/Core/Llvm/Metadata/Graph.hs +++ b/DDC/Core/Llvm/Metadata/Graph.hs @@ -212,7 +212,7 @@ -- | Get the sources of a tree. -sources :: Eq a => a -> Tree a -> [a] +sources :: a -> Tree a -> [a] sources x (Tree (d, r)) = [y | y <- d, r y x] diff --git a/DDC/Core/Llvm/Metadata/Tbaa.hs b/DDC/Core/Llvm/Metadata/Tbaa.hs --- a/DDC/Core/Llvm/Metadata/Tbaa.hs +++ b/DDC/Core/Llvm/Metadata/Tbaa.hs @@ -6,14 +6,12 @@ where import DDC.Llvm.Syntax.Metadata import DDC.Llvm.Pretty.Metadata () -import DDC.Type.Exp -import DDC.Type.Compounds -import DDC.Type.Predicates -import DDC.Type.Collect +import DDC.Core.Collect import DDC.Type.Env (KindEnv) +import DDC.Type.Exp.Simple import DDC.Core.Llvm.Metadata.Graph import DDC.Core.Llvm.Convert.Base -import DDC.Base.Pretty hiding (empty) +import DDC.Data.Pretty hiding (empty) import qualified DDC.Type.Env as Env import qualified DDC.Core.Salt as A import qualified DDC.Llvm.Syntax as V @@ -125,7 +123,7 @@ -- | Attach relevant metadata to instructions -annot :: (BindStruct (c A.Name) A.Name, Show (c A.Name)) +annot :: (BindStruct (c A.Name) A.Name) => KindEnv A.Name -> MDSuper -- ^ Metadata -> [c A.Name] -- ^ Things to lookup for Meta data. diff --git a/DDC/Llvm/Pretty/Attr.hs b/DDC/Llvm/Pretty/Attr.hs --- a/DDC/Llvm/Pretty/Attr.hs +++ b/DDC/Llvm/Pretty/Attr.hs @@ -2,7 +2,7 @@ -- | Attributes for functions and parameters. module DDC.Llvm.Pretty.Attr where import DDC.Llvm.Syntax.Attr -import DDC.Base.Pretty +import DDC.Data.Pretty instance Pretty FuncAttr where diff --git a/DDC/Llvm/Pretty/Exp.hs b/DDC/Llvm/Pretty/Exp.hs --- a/DDC/Llvm/Pretty/Exp.hs +++ b/DDC/Llvm/Pretty/Exp.hs @@ -5,7 +5,7 @@ where import DDC.Llvm.Syntax.Exp import DDC.Llvm.Pretty.Type () -import DDC.Base.Pretty +import DDC.Data.Pretty import Data.Text (Text) import qualified Data.Text as T diff --git a/DDC/Llvm/Pretty/Function.hs b/DDC/Llvm/Pretty/Function.hs --- a/DDC/Llvm/Pretty/Function.hs +++ b/DDC/Llvm/Pretty/Function.hs @@ -5,7 +5,7 @@ import DDC.Llvm.Pretty.Attr () import DDC.Llvm.Pretty.Instr import DDC.Llvm.Pretty.Base -import DDC.Base.Pretty +import DDC.Data.Pretty import Prelude hiding ((<$>)) diff --git a/DDC/Llvm/Pretty/Instr.hs b/DDC/Llvm/Pretty/Instr.hs --- a/DDC/Llvm/Pretty/Instr.hs +++ b/DDC/Llvm/Pretty/Instr.hs @@ -10,9 +10,9 @@ import DDC.Llvm.Pretty.Prim () import DDC.Llvm.Pretty.Metadata () import DDC.Llvm.Pretty.Base +import DDC.Data.Pretty import Data.List import qualified Data.Foldable as Seq -import DDC.Base.Pretty ------------------------------------------------------------------------------- diff --git a/DDC/Llvm/Pretty/Metadata.hs b/DDC/Llvm/Pretty/Metadata.hs --- a/DDC/Llvm/Pretty/Metadata.hs +++ b/DDC/Llvm/Pretty/Metadata.hs @@ -3,7 +3,7 @@ import DDC.Llvm.Syntax.Metadata import DDC.Llvm.Pretty.Type () import DDC.Llvm.Pretty.Base -import DDC.Base.Pretty +import DDC.Data.Pretty ------------------------------------------------------------------------------- diff --git a/DDC/Llvm/Pretty/Module.hs b/DDC/Llvm/Pretty/Module.hs --- a/DDC/Llvm/Pretty/Module.hs +++ b/DDC/Llvm/Pretty/Module.hs @@ -7,7 +7,7 @@ import DDC.Llvm.Pretty.Exp () import DDC.Llvm.Pretty.Metadata import DDC.Llvm.Pretty.Base -import DDC.Base.Pretty +import DDC.Data.Pretty ------------------------------------------------------------------------------- diff --git a/DDC/Llvm/Pretty/Prim.hs b/DDC/Llvm/Pretty/Prim.hs --- a/DDC/Llvm/Pretty/Prim.hs +++ b/DDC/Llvm/Pretty/Prim.hs @@ -1,7 +1,7 @@ module DDC.Llvm.Pretty.Prim where import DDC.Llvm.Syntax.Prim -import DDC.Base.Pretty +import DDC.Data.Pretty instance Pretty Op where diff --git a/DDC/Llvm/Pretty/Type.hs b/DDC/Llvm/Pretty/Type.hs --- a/DDC/Llvm/Pretty/Type.hs +++ b/DDC/Llvm/Pretty/Type.hs @@ -2,7 +2,7 @@ module DDC.Llvm.Pretty.Type where import DDC.Llvm.Syntax.Type import DDC.Llvm.Pretty.Attr () -import DDC.Base.Pretty +import DDC.Data.Pretty instance Pretty Param where diff --git a/DDC/Llvm/Transform/Flatten.hs b/DDC/Llvm/Transform/Flatten.hs --- a/DDC/Llvm/Transform/Flatten.hs +++ b/DDC/Llvm/Transform/Flatten.hs @@ -13,7 +13,7 @@ (flatten) where import DDC.Llvm.Syntax -import DDC.Control.Monad.Check +import DDC.Control.Check import Data.Sequence (Seq, (|>), (><)) import Control.Monad import qualified Data.Sequence as Seq diff --git a/DDC/Llvm/Transform/Simpl.hs b/DDC/Llvm/Transform/Simpl.hs --- a/DDC/Llvm/Transform/Simpl.hs +++ b/DDC/Llvm/Transform/Simpl.hs @@ -13,7 +13,7 @@ where import DDC.Llvm.Syntax import DDC.Llvm.Analysis.Defs -import DDC.Control.Monad.Check +import DDC.Control.Check import Data.Sequence (Seq, (|>)) import Data.Map (Map) import qualified Data.Map as Map diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2014 The Disciplined Disciple Compiler Strike Force +Copyrite (K) 2007-2016 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy diff --git a/ddc-core-llvm.cabal b/ddc-core-llvm.cabal --- a/ddc-core-llvm.cabal +++ b/ddc-core-llvm.cabal @@ -1,5 +1,5 @@ Name: ddc-core-llvm -Version: 0.4.2.2 +Version: 0.4.3.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force @@ -14,17 +14,16 @@ Library Build-Depends: - base >= 4.6 && < 4.9, + base >= 4.6 && < 4.10, array >= 0.4 && < 0.6, bytestring >= 0.10 && < 0.11, - containers == 0.5.*, text >= 1.0 && < 1.3, - transformers == 0.4.*, + containers == 0.5.*, + transformers == 0.5.*, 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.* + ddc-core == 0.4.3.*, + ddc-core-simpl == 0.4.3.*, + ddc-core-salt == 0.4.3.* Exposed-modules: DDC.Core.Llvm.Metadata.Graph