llvm-general 3.2.0.6 → 3.2.0.7
raw patch · 17 files changed
+153/−287 lines, 17 filesdep ~arraydep ~basedep ~containerssetup-changed
Dependency ranges changed: array, base, containers
Files
- Setup.hs +6/−6
- llvm-general.cabal +6/−9
- src/Control/Monad/AnyCont/Class.hs +0/−8
- src/Control/Monad/Phased.hs +0/−36
- src/Control/Monad/Phased/Class.hs +0/−46
- src/Control/Monad/Trans/Phased.hs +0/−33
- src/LLVM/General/Internal/Attribute.hs +1/−0
- src/LLVM/General/Internal/BasicBlock.hs +3/−4
- src/LLVM/General/Internal/CallingConvention.hs +4/−3
- src/LLVM/General/Internal/Constant.hs +15/−15
- src/LLVM/General/Internal/DecodeAST.hs +4/−18
- src/LLVM/General/Internal/EncodeAST.hs +15/−23
- src/LLVM/General/Internal/FFI/LLVMCTypes.hsc +2/−2
- src/LLVM/General/Internal/Instruction.hs +11/−10
- src/LLVM/General/Internal/InstructionDefs.hs +8/−7
- src/LLVM/General/Internal/Module.hs +64/−54
- src/LLVM/General/Internal/Type.hs +14/−13
Setup.hs view
@@ -1,3 +1,4 @@+import Control.Exception (SomeException, try) import Control.Monad import Data.Monoid import Data.Maybe@@ -28,8 +29,8 @@ OSX -> ("DYLD_LIBRARY_PATH",":") _ -> ("LD_LIBRARY_PATH",":") addToLdLibraryPath s = do- v <- lookupEnv ldLibraryPathVar- setEnv ldLibraryPathVar (s ++ maybe "" (ldLibraryPathSep ++) v)+ v <- try $ getEnv ldLibraryPathVar :: IO (Either SomeException String)+ setEnv ldLibraryPathVar (s ++ either (const "") (ldLibraryPathSep ++) v) getLLVMConfig configFlags = do let verbosity = fromFlag $ configVerbosity configFlags -- preconfigure the configuration-generating program "llvm-config"@@ -96,9 +97,8 @@ haddockHook = \packageDescription localBuildInfo userHooks haddockFlags -> do let v = "GHCRTS"- oldGhcRts <- lookupEnv v- setEnv v (maybe id (\o n -> o ++ " " ++ n) oldGhcRts "-K32M")+ oldGhcRts <- try $ getEnv v :: IO (Either SomeException String)+ setEnv v (either (const id) (\o n -> o ++ " " ++ n) oldGhcRts "-K32M") haddockHook simpleUserHooks packageDescription localBuildInfo userHooks haddockFlags- maybe (unsetEnv v) (setEnv v) oldGhcRts+ either (const (unsetEnv v)) (setEnv v) oldGhcRts }-
llvm-general.cabal view
@@ -1,5 +1,5 @@ name: llvm-general-version: 3.2.0.6+version: 3.2.0.7 license: BSD3 license-file: LICENSE author: Benjamin S.Scarlet <fgthb0@greynode.net>@@ -33,7 +33,7 @@ type: git location: git://github.com/bscarlet/llvm-general.git branch: llvm-3.2- tag: v3.2.0.6+ tag: v3.2.0.7 flag shared-llvm description: link against llvm shared rather than static library@@ -47,15 +47,15 @@ build-tools: llvm-config ghc-options: -fwarn-unused-imports build-depends: - base >= 4.6.0.0 && < 5,+ base >= 4.5.0.0 && < 5, text >= 0.11.2.1, bytestring >= 0.9.1.10, transformers >= 0.3.0.0, mtl >= 2.0.1.0, template-haskell >= 2.5.0.0,- containers >= 0.5.0.0,+ containers >= 0.4.2.1, parsec >= 3.1.3,- array >= 0.4.0.1,+ array >= 0.4.0.0, setenv >= 0.1.0 extra-libraries: stdc++ hs-source-dirs: src@@ -92,9 +92,6 @@ LLVM.General.Transforms other-modules:- Control.Monad.Phased- Control.Monad.Phased.Class- Control.Monad.Trans.Phased Control.Monad.AnyCont Control.Monad.AnyCont.Class Control.Monad.Trans.AnyCont@@ -185,7 +182,7 @@ test-framework-quickcheck2 >= 0.3.0.1, QuickCheck >= 2.5.1.1, llvm-general >= 0.1,- containers >= 0.5.0.0+ containers >= 0.4.2.1 hs-source-dirs: test main-is: Test.hs other-modules:
src/Control/Monad/AnyCont/Class.hs view
@@ -12,7 +12,6 @@ import qualified Control.Monad.Trans.AnyCont as AnyCont import Control.Monad.Trans.Error as Error import Control.Monad.Trans.State as State-import Control.Monad.Trans.Phased as Phased class MonadAnyCont b m | m -> b where anyContToM :: (forall r . (a -> b r) -> b r) -> m a@@ -26,10 +25,6 @@ anyContToM = lift . anyContToM scopeAnyCont = mapErrorT scopeAnyCont -instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (PhasedT m) where- anyContToM = lift . anyContToM- scopeAnyCont = mapPhasedT scopeAnyCont- instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (StateT s m) where anyContToM = lift . anyContToM scopeAnyCont = StateT . (scopeAnyCont .) . runStateT@@ -39,9 +34,6 @@ instance LiftAnyCont b b where liftAnyCont c = c--instance LiftAnyCont b m => LiftAnyCont b (PhasedT m) where- liftAnyCont c = \q -> PhasedT (liftAnyCont c (unPhasedT . q)) instance LiftAnyCont b m => LiftAnyCont b (StateT s m) where liftAnyCont c = \q -> StateT $ \s -> (liftAnyCont c (($ s) . runStateT . q))
− src/Control/Monad/Phased.hs
@@ -1,36 +0,0 @@-{-# LANGUAGE- FlexibleInstances,- MultiParamTypeClasses,- UndecidableInstances- #-}-module Control.Monad.Phased (- MonadPhased(..),- PhasedT(..),- runPhasedT,- forInterleavedM,- iap,- defer,- runInterleaved,- mapPhasedT- ) where--import Control.Monad-import Control.Monad.Trans.Phased--import Control.Monad.Trans.Class-import Control.Monad.State.Class-import Control.Monad.Reader.Class-import Control.Monad.Error.Class-import Control.Monad.Phased.Class--instance MonadState s m => MonadState s (PhasedT m) where- state = lift . state--instance MonadReader r m => MonadReader r (PhasedT m) where- ask = lift ask- local f = PhasedT . local f . liftM (either (Left . local f) Right) . unPhasedT--instance (MonadError e m) => MonadError e (PhasedT m) where- throwError = lift . throwError- catchError pa ph = mapPhasedT (`catchError` (unPhasedT . ph)) pa-
− src/Control/Monad/Phased/Class.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE- MultiParamTypeClasses,- UndecidableInstances,- FlexibleInstances,- TupleSections- #-}-module Control.Monad.Phased.Class where--import Control.Monad.Trans.Class-import Control.Monad.Trans.Phased-import Control.Monad.Trans.AnyCont--class Monad m => MonadPhased m where- later :: m a -> m a- interleavePhasesWith :: (a -> b -> c) -> m a -> m b -> m c- mergePhases :: m a -> m a--iap :: MonadPhased m => m (a -> b) -> m a -> m b-iap = interleavePhasesWith ($)--runInterleaved :: (MonadPhased m) => [m a] -> m [a]-runInterleaved = foldr (interleavePhasesWith (:)) (return [])--forInterleavedM x = runInterleaved . flip map x--defer :: MonadPhased m => m ()-defer = later (return ())--instance Monad m => MonadPhased (PhasedT m) where- later = PhasedT . return . Left- interleavePhasesWith p (PhasedT mx) (PhasedT my) = PhasedT $ do- x <- mx- y <- my- return $ case (x,y) of- (Right a, Right b) -> Right (p a b)- _ -> Left $ interleavePhasesWith p (stall x) (stall y)- where stall = either id return- mergePhases = lift . runPhasedT--instance MonadPhased m => MonadPhased (AnyContT m) where- later = lift . later . flip runAnyContT return- interleavePhasesWith p mx my = - anyContT $ (>>=) $ interleavePhasesWith p (runAnyContT mx return) (runAnyContT my return)- mergePhases ma = anyContT (mergePhases (runAnyContT ma return) >>= )--
− src/Control/Monad/Trans/Phased.hs
@@ -1,33 +0,0 @@-module Control.Monad.Trans.Phased where--import Control.Monad-import Control.Applicative-import Control.Monad.Trans.Class-import Control.Monad.IO.Class--newtype PhasedT m a = PhasedT { unPhasedT :: m (Either (PhasedT m a) a) }--instance Functor m => Functor (PhasedT m) where- fmap f = PhasedT . fmap (either (Left . fmap f) (Right . f)) . unPhasedT--instance (Functor m, Monad m) => Applicative (PhasedT m) where- pure = return- (<*>) = ap--instance Monad m => Monad (PhasedT m) where- k >>= f = PhasedT $ unPhasedT k >>= either (return . Left . (>>= f)) (unPhasedT . f)- return = PhasedT . return . Right- fail = PhasedT . fail--instance MonadTrans PhasedT where- lift = PhasedT . liftM Right--runPhasedT :: Monad m => PhasedT m a -> m a-runPhasedT = either runPhasedT return <=< unPhasedT--instance MonadIO m => MonadIO (PhasedT m) where- liftIO = PhasedT . liftM Right . liftIO--mapPhasedT :: Monad n => (m (Either (PhasedT m a) a) -> n (Either (PhasedT m a) b)) -> PhasedT m a -> PhasedT n b-mapPhasedT f (PhasedT x) = PhasedT $ return (either (Left . (mapPhasedT f)) Right) `ap` f x-
src/LLVM/General/Internal/Attribute.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses,+ ConstraintKinds, FlexibleInstances #-}
src/LLVM/General/Internal/BasicBlock.hs view
@@ -2,7 +2,6 @@ import Control.Monad import Control.Monad.Trans-import Control.Monad.Phased import Foreign.Ptr import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI@@ -15,13 +14,13 @@ import qualified LLVM.General.AST.Instruction as A -getBasicBlockTerminator :: Ptr FFI.BasicBlock -> DecodeAST (A.Named A.Terminator)+getBasicBlockTerminator :: Ptr FFI.BasicBlock -> DecodeAST (DecodeAST (A.Named A.Terminator)) getBasicBlockTerminator = decodeM <=< (liftIO . FFI.getBasicBlockTerminator) -getNamedInstructions :: Ptr FFI.BasicBlock -> DecodeAST [A.Named A.Instruction]+getNamedInstructions :: Ptr FFI.BasicBlock -> DecodeAST (DecodeAST [A.Named A.Instruction]) getNamedInstructions b = do ffiInstructions <- liftIO $ FFI.getXs (FFI.getFirstInstruction b) FFI.getNextInstruction let n = length ffiInstructions- forInterleavedM (take (n-1) ffiInstructions) $ decodeM+ liftM sequence . forM (take (n-1) ffiInstructions) $ decodeM
src/LLVM/General/Internal/CallingConvention.hs view
@@ -10,6 +10,7 @@ import Foreign.C.Types (CUInt(..)) import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI+import LLVM.General.Internal.FFI.LLVMCTypes (callConvP) import qualified LLVM.General.AST.CallingConvention as A.CC @@ -24,8 +25,8 @@ instance Monad m => DecodeM m A.CC.CallingConvention FFI.CallConv where decodeM cc = return $ case cc of- [FFI.callConvP|C|] -> A.CC.C- [FFI.callConvP|Fast|] -> A.CC.Fast- [FFI.callConvP|Cold|] -> A.CC.Cold+ [callConvP|C|] -> A.CC.C+ [callConvP|Fast|] -> A.CC.Fast+ [callConvP|Cold|] -> A.CC.Cold FFI.CallConv (CUInt 10) -> A.CC.GHC FFI.CallConv (CUInt ci) | ci >= 64 -> A.CC.Numbered (fromIntegral ci)
src/LLVM/General/Internal/Constant.hs view
@@ -26,7 +26,7 @@ import qualified LLVM.General.Internal.FFI.Constant as FFI import qualified LLVM.General.Internal.FFI.GlobalValue as FFI import qualified LLVM.General.Internal.FFI.Instruction as FFI-import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI+import LLVM.General.Internal.FFI.LLVMCTypes (valueSubclassIdP) import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.General.Internal.FFI.User as FFI import qualified LLVM.General.Internal.FFI.Value as FFI@@ -134,16 +134,16 @@ decodeM <=< liftIO . FFI.getConstantDataSequentialElementAsConstant c . fromIntegral case valueSubclassId of- [FFI.valueSubclassIdP|Function|] -> globalRef- [FFI.valueSubclassIdP|GlobalAlias|] -> globalRef- [FFI.valueSubclassIdP|GlobalVariable|] -> globalRef- [FFI.valueSubclassIdP|ConstantInt|] -> do+ [valueSubclassIdP|Function|] -> globalRef+ [valueSubclassIdP|GlobalAlias|] -> globalRef+ [valueSubclassIdP|GlobalVariable|] -> globalRef+ [valueSubclassIdP|ConstantInt|] -> do np <- alloca wsp <- liftIO $ FFI.getConstantIntWords c np n <- peek np words <- decodeM (n, wsp) return $ A.C.Int (A.typeBits t) (foldr (\b a -> (a `shiftL` 64) .|. fromIntegral (b :: Word64)) 0 words)- [FFI.valueSubclassIdP|ConstantFP|] -> do+ [valueSubclassIdP|ConstantFP|] -> do let A.FloatingPointType nBits fmt = t ws <- allocaWords nBits liftIO $ FFI.getConstantFloatWords c ws@@ -157,22 +157,22 @@ (128, A.PairOfFloats) -> A.F.PPC_FP128 <$> peekByteOff (castPtr ws) 8 <*> peekByteOff (castPtr ws) 0 _ -> error $ "don't know how to decode floating point constant of type: " ++ show t )- [FFI.valueSubclassIdP|ConstantPointerNull|] -> return $ A.C.Null t- [FFI.valueSubclassIdP|ConstantAggregateZero|] -> return $ A.C.Null t- [FFI.valueSubclassIdP|UndefValue|] -> return $ A.C.Undef t- [FFI.valueSubclassIdP|BlockAddress|] -> + [valueSubclassIdP|ConstantPointerNull|] -> return $ A.C.Null t+ [valueSubclassIdP|ConstantAggregateZero|] -> return $ A.C.Null t+ [valueSubclassIdP|UndefValue|] -> return $ A.C.Undef t+ [valueSubclassIdP|BlockAddress|] -> return A.C.BlockAddress `ap` (getGlobalName =<< do liftIO $ FFI.isAGlobalValue =<< FFI.getBlockAddressFunction c) `ap` (getLocalName =<< do liftIO $ FFI.getBlockAddressBlock c)- [FFI.valueSubclassIdP|ConstantStruct|] -> + [valueSubclassIdP|ConstantStruct|] -> return A.C.Struct `ap` (return $ A.isPacked t) `ap` getConstantOperands- [FFI.valueSubclassIdP|ConstantDataArray|] -> + [valueSubclassIdP|ConstantDataArray|] -> return A.C.Array `ap` (return $ A.elementType t) `ap` getConstantData- [FFI.valueSubclassIdP|ConstantArray|] -> + [valueSubclassIdP|ConstantArray|] -> return A.C.Array `ap` (return $ A.elementType t) `ap` getConstantOperands- [FFI.valueSubclassIdP|ConstantDataVector|] -> + [valueSubclassIdP|ConstantDataVector|] -> return A.C.Vector `ap` getConstantData- [FFI.valueSubclassIdP|ConstantExpr|] -> do+ [valueSubclassIdP|ConstantExpr|] -> do cppOpcode <- liftIO $ FFI.getConstantCPPOpcode c $( TH.caseE [| cppOpcode |] $ do
src/LLVM/General/Internal/DecodeAST.hs view
@@ -10,7 +10,6 @@ import Control.Applicative import Control.Monad.State-import Control.Monad.Phased import Control.Monad.AnyCont import Foreign.Ptr@@ -56,14 +55,13 @@ metadataNodes = Map.empty, metadataKinds = Array.listArray (1,0) [] }-newtype DecodeAST a = DecodeAST { unDecodeAST :: AnyContT (PhasedT (StateT DecodeState IO)) a }+newtype DecodeAST a = DecodeAST { unDecodeAST :: AnyContT (StateT DecodeState IO) a } deriving ( Applicative, Functor, Monad, MonadIO,- MonadState DecodeState,- MonadPhased+ MonadState DecodeState ) instance MonadAnyCont IO DecodeAST where@@ -71,27 +69,15 @@ scopeAnyCont = DecodeAST . scopeAnyCont . unDecodeAST runDecodeAST :: DecodeAST a -> IO a-runDecodeAST d = flip evalStateT initialDecode . runPhasedT . flip runAnyContT return . unDecodeAST $ d+runDecodeAST d = flip evalStateT initialDecode . flip runAnyContT return . unDecodeAST $ d localScope :: DecodeAST a -> DecodeAST a-localScope (DecodeAST x) = DecodeAST (mapAnyContT pScope (tweak x))+localScope (DecodeAST x) = DecodeAST (tweak x) where tweak x = do modify (\s@DecodeState { localNameCounter = Nothing } -> s { localNameCounter = Just 0 }) r <- x modify (\s@DecodeState { localNameCounter = Just _ } -> s { localNameCounter = Nothing }) return r- pScope (PhasedT x) = PhasedT $ do- let s0 `withLocalsFrom` s1 = s0 { - localNameCounter = localNameCounter s1- }- state <- get -- save the state- a <- x- state' <- get -- get the modified state- put $ state' `withLocalsFrom` state -- revert the local part- -- Finally here's the fun bit - in the Left case where we're coming back to a deferment point,- -- prepend an action which reinstates the local state, but re-wrap with pScope to continue- -- containment.- return $ either (Left . pScope . (modify (`withLocalsFrom` state') >>)) Right a getName :: (Ptr a -> IO CString) -> Ptr a
src/LLVM/General/Internal/EncodeAST.hs view
@@ -10,7 +10,6 @@ import Control.Exception import Control.Monad.State-import Control.Monad.Phased import Control.Monad.Error import Control.Monad.AnyCont @@ -41,13 +40,12 @@ encodeStateNamedTypes :: Map A.Name (Ptr FFI.Type) } -newtype EncodeAST a = EncodeAST { unEncodeAST :: AnyContT (PhasedT (ErrorT String (StateT EncodeState IO))) a }+newtype EncodeAST a = EncodeAST { unEncodeAST :: AnyContT (ErrorT String (StateT EncodeState IO)) a } deriving ( Functor, Monad, MonadIO, MonadState EncodeState,- MonadPhased, MonadError String ) @@ -76,7 +74,7 @@ encodeStateMDNodes = Map.empty, encodeStateNamedTypes = Map.empty }- flip evalStateT initEncodeState . runErrorT . runPhasedT . flip runAnyContT return $ a+ flip evalStateT initEncodeState . runErrorT . flip runAnyContT return $ a withName :: A.Name -> (CString -> IO a) -> IO a withName (A.Name n) = withCString n@@ -86,25 +84,19 @@ encodeM (A.Name n) = encodeM n encodeM _ = encodeM "" --- contain modifications to the local part of the encode state - in this case all those except--- those to encodeStateAllBlocks-encodeScope :: EncodeAST a -> EncodeAST a-encodeScope (EncodeAST x) = - EncodeAST . mapAnyContT pScope $ x -- get inside the boring wrappers down to the phasing- where pScope (PhasedT x) = PhasedT $ do- let s0 `withLocalsFrom` s1 = s0 { - encodeStateLocals = encodeStateLocals s1,- encodeStateBlocks = encodeStateBlocks s1- }- state <- get -- save the state- a <- x- state' <- get -- get the modified state- put $ state' `withLocalsFrom` state -- revert the local part- -- Finally here's the fun bit - in the Left case where we're coming back to a deferment point,- -- prepend an action which reinstates the local state, but re-wrap with pScope to continue- -- containment.- return $ either (Left . pScope . (modify (`withLocalsFrom` state') >>)) Right a-+phase :: EncodeAST a -> EncodeAST (EncodeAST a)+phase p = do+ let s0 `withLocalsFrom` s1 = s0 { + encodeStateLocals = encodeStateLocals s1,+ encodeStateBlocks = encodeStateBlocks s1+ }+ s <- get+ return $ do+ s' <- get+ put $ s' `withLocalsFrom` s+ r <- p+ modify (`withLocalsFrom` s')+ return r define :: (Ord n, FFI.DescendentOf p v) => (EncodeState -> Map n (Ptr p))
src/LLVM/General/Internal/FFI/LLVMCTypes.hsc view
@@ -170,11 +170,11 @@ #{inject TYPE_KIND, TypeKind, TypeKind, typeKind, TK_Rec} newtype ParamAttr = ParamAttr CUInt- deriving (Eq, Read, Show, Bits, Typeable, Data)+ deriving (Eq, Read, Show, Bits, Typeable, Data, Num) #define PA_Rec(n) { #n, LLVM ## n ## Attribute }, #{inject PARAM_ATTR, ParamAttr, ParamAttr, paramAttr, PA_Rec} newtype FunctionAttr = FunctionAttr CUInt- deriving (Eq, Read, Show, Bits, Typeable, Data)+ deriving (Eq, Read, Show, Bits, Typeable, Data, Num) #define FA_Rec(n,a) { #n, LLVM ## n ## a }, #{inject FUNCTION_ATTR, FunctionAttr, FunctionAttr, functionAttr, FA_Rec}
src/LLVM/General/Internal/Instruction.hs view
@@ -12,13 +12,13 @@ import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH import qualified LLVM.General.Internal.InstructionDefs as ID+import LLVM.General.Internal.InstructionDefs (instrP) import Data.Functor import Control.Monad import Control.Monad.Trans import Control.Monad.AnyCont import Control.Monad.State-import Control.Monad.Phased import Foreign.Ptr @@ -70,10 +70,10 @@ let op n = decodeM =<< (liftIO $ FFI.getOperand (FFI.upCast i) n) successor n = decodeM =<< (liftIO $ FFI.isABasicBlock =<< FFI.getOperand (FFI.upCast i) n) case n of- [ID.instrP|Ret|] -> do+ [instrP|Ret|] -> do returnOperand' <- if nOps == 0 then return Nothing else Just <$> op 0 return $ A.Ret { A.returnOperand = returnOperand', A.metadata' = md }- [ID.instrP|Br|] -> do+ [instrP|Br|] -> do n <- liftIO $ FFI.getNumOperands (FFI.upCast i) case n of 1 -> do@@ -89,7 +89,7 @@ A.trueDest = trueDest, A.metadata' = md }- [ID.instrP|Switch|] -> do+ [instrP|Switch|] -> do op0 <- op 0 dd <- successor 1 let nCases = (nOps - 2) `div` 2@@ -104,7 +104,7 @@ A.dests = dests, A.metadata' = md }- [ID.instrP|IndirectBr|] -> do+ [instrP|IndirectBr|] -> do op0 <- op 0 let nDests = nOps - 1 dests <- allocaArray nDests@@ -115,7 +115,7 @@ A.possibleDests = dests, A.metadata' = md }- [ID.instrP|Invoke|] -> do+ [instrP|Invoke|] -> do cc <- decodeM =<< liftIO (FFI.getInstructionCallConv i) rAttrs <- callInstAttr i 0 fv <- liftIO $ FFI.getCallInstCalledValue i@@ -134,13 +134,13 @@ A.exceptionDest = ed, A.metadata' = md }- [ID.instrP|Resume|] -> do+ [instrP|Resume|] -> do op0 <- op 0 return A.Resume { A.operand0' = op0, A.metadata' = md }- [ID.instrP|Unreachable|] -> do+ [instrP|Unreachable|] -> do return A.Unreachable { A.metadata' = md }@@ -598,10 +598,11 @@ ) -instance DecodeM DecodeAST a (Ptr FFI.Instruction) => DecodeM DecodeAST (A.Named a) (Ptr FFI.Instruction) where+instance DecodeM DecodeAST a (Ptr FFI.Instruction) => DecodeM DecodeAST (DecodeAST (A.Named a)) (Ptr FFI.Instruction) where decodeM i = do t <- typeOf i- (if t == A.VoidType then (return A.Do) else (return (A.:=) `ap` getLocalName i)) `ap` (do defer; decodeM i)+ w <- if t == A.VoidType then (return A.Do) else (return (A.:=) `ap` getLocalName i)+ return $ return w `ap` decodeM i instance EncodeM EncodeAST a (Ptr FFI.Instruction) => EncodeM EncodeAST (A.Named a) (Ptr FFI.Instruction) where encodeM (A.Do o) = encodeM o
src/LLVM/General/Internal/InstructionDefs.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE TemplateHaskell #-}- module LLVM.General.Internal.InstructionDefs ( astInstructionRecs, astConstantRecs,@@ -42,13 +41,15 @@ refName x = x innerJoin :: Ord k => Map k a -> Map k b -> Map k (a,b)-innerJoin = Map.mergeWithKey (\_ a b -> Just (a,b)) (const Map.empty) (const Map.empty)- +innerJoin = Map.intersectionWith (,)+ outerJoin :: Ord k => Map k a -> Map k b -> Map k (Maybe a, Maybe b)-outerJoin = Map.mergeWithKey - (\_ a b -> Just (Just a, Just b))- (Map.map $ \a -> (Just a, Nothing))- (Map.map $ \b -> (Nothing, Just b))+outerJoin xs ys = Map.unionWith combine+ (Map.map (\a -> (Just a, Nothing)) xs)+ (Map.map (\b -> (Nothing, Just b)) ys)+ where+ combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b)+ combine _ _ = error "outerJoin: the impossible happened" instrP = TH.QuasiQuoter { TH.quoteExp = undefined,
src/LLVM/General/Internal/Module.hs view
@@ -9,7 +9,6 @@ import Control.Monad.Trans import Control.Monad.State-import Control.Monad.Phased import Control.Monad.AnyCont import Control.Applicative import Control.Exception@@ -97,6 +96,8 @@ getDataLayout :: Ptr FFI.Module -> IO (Maybe A.DataLayout) getDataLayout m = parseDataLayout <$> (decodeM =<< FFI.getDataLayout m) +type P a = a -> a+ -- | Build an LLVM.General.'Module' from a LLVM.General.AST.'LLVM.General.AST.Module' - i.e. -- lower an AST from Haskell into C++ objects. withModuleFromAST :: Context -> A.Module -> (Module -> IO a) -> IO (Either String a)@@ -107,37 +108,41 @@ bracket makeModule FFI.disposeModule $ \m -> do maybe (return ()) (setDataLayout m) dataLayout maybe (return ()) (setTargetTriple m) triple- r <- runEncodeAST context $ forInterleavedM definitions $ \d -> case d of+ let sequencePhases :: EncodeAST [EncodeAST (EncodeAST (EncodeAST (EncodeAST ())))] -> EncodeAST ()+ sequencePhases l = (l >>= (sequence >=> sequence >=> sequence >=> sequence)) >> (return ())++ r <- runEncodeAST context $ sequencePhases $ forM definitions $ \d -> case d of A.TypeDefinition n t -> do t' <- createNamedType n defineType n t'- defer- maybe (return ()) (setNamedType t') t+ return $ do+ maybe (return ()) (setNamedType t') t+ return . return . return $ return () - A.MetadataNodeDefinition i os -> do- replicateM_ 2 defer+ A.MetadataNodeDefinition i os -> return . return $ do t <- liftIO $ FFI.createTemporaryMDNodeInContext c defineMDNode i t- defer- n <- encodeM (A.MetadataNode os)- liftIO $ FFI.replaceAllUsesWith (FFI.upCast t) (FFI.upCast n)- defineMDNode i n- liftIO $ FFI.destroyTemporaryMDNode t+ return $ do+ n <- encodeM (A.MetadataNode os)+ liftIO $ FFI.replaceAllUsesWith (FFI.upCast t) (FFI.upCast n)+ defineMDNode i n+ liftIO $ FFI.destroyTemporaryMDNode t+ return $ return () - A.NamedMetadataDefinition n ids -> do- replicateM_ 4 defer+ A.NamedMetadataDefinition n ids -> return . return . return . return $ do n <- encodeM n ids <- encodeM (map A.MetadataNodeReference ids) nm <- liftIO $ FFI.getOrAddNamedMetadata m n liftIO $ FFI.namedMetadataAddOperands nm ids+ return () A.ModuleInlineAssembly s -> do s <- encodeM s liftIO $ FFI.moduleAppendInlineAsm m (FFI.ModuleAsm s)+ return . return . return . return $ return () - A.GlobalDefinition g -> do- replicateM_ 2 defer- g' :: Ptr FFI.GlobalValue <- case g of+ A.GlobalDefinition g -> return . phase $ do+ eg' :: EncodeAST (Ptr FFI.GlobalValue) <- case g of g@(A.GlobalVariable { A.G.name = n }) -> do typ <- encodeM (A.G.type' g) g' <- liftIO $ withName n $ \gName -> @@ -151,18 +156,18 @@ FFI.setUnnamedAddr (FFI.upCast g') hua ic <- encodeM (A.G.isConstant g) FFI.setGlobalConstant g' ic- defer- maybe (return ()) ((liftIO . FFI.setInitializer g') <=< encodeM) (A.G.initializer g)- setSection g' (A.G.section g)- setAlignment g' (A.G.alignment g)- return (FFI.upCast g')+ return $ do+ maybe (return ()) ((liftIO . FFI.setInitializer g') <=< encodeM) (A.G.initializer g)+ setSection g' (A.G.section g)+ setAlignment g' (A.G.alignment g)+ return (FFI.upCast g') (a@A.G.GlobalAlias { A.G.name = n }) -> do typ <- encodeM (A.G.type' a) a' <- liftIO $ withName n $ \name -> FFI.justAddAlias m typ name defineGlobal n a'- defer- (liftIO . FFI.setAliasee a') =<< encodeM (A.G.aliasee a)- return (FFI.upCast a')+ return $ do+ (liftIO . FFI.setAliasee a') =<< encodeM (A.G.aliasee a)+ return (FFI.upCast a') (A.Function _ _ cc rAttrs resultType fName (args,isVarArgs) attrs _ _ blocks) -> do typ <- encodeM $ A.FunctionType resultType (map (\(A.Parameter t _ _) -> t) args) isVarArgs f <- liftIO . withName fName $ \fName -> FFI.addFunction m fName typ@@ -174,11 +179,10 @@ liftIO $ setFunctionAttrs f attrs setSection f (A.G.section g) setAlignment f (A.G.alignment g)- encodeScope $ do- forM blocks $ \(A.BasicBlock bName _ _) -> do- b <- liftIO $ withName bName $ \bName -> FFI.appendBasicBlockInContext c f bName- defineBasicBlock fName bName b- defer+ forM blocks $ \(A.BasicBlock bName _ _) -> do+ b <- liftIO $ withName bName $ \bName -> FFI.appendBasicBlockInContext c f bName+ defineBasicBlock fName bName b+ phase $ do let nParams = length args ps <- allocaArray nParams liftIO $ FFI.getParams f ps@@ -190,7 +194,7 @@ attrs <- encodeM attrs liftIO $ FFI.addAttribute p attrs return ()- finishInstrs <- forInterleavedM blocks $ \(A.BasicBlock bName namedInstrs term) -> do+ finishInstrs <- forM blocks $ \(A.BasicBlock bName namedInstrs term) -> do b <- encodeM bName (do builder <- gets encodeStateBuilder@@ -199,10 +203,13 @@ (encodeM term :: EncodeAST (Ptr FFI.Instruction)) return (sequence_ finishes) sequence_ finishInstrs- return (FFI.upCast f)- setLinkage g' (A.G.linkage g)- setVisibility g' (A.G.visibility g)-+ return (FFI.upCast f)+ return $ do+ g' <- eg'+ setLinkage g' (A.G.linkage g)+ setVisibility g' (A.G.visibility g)+ return $ return ()+ either (return . Left) (const $ Right <$> f (Module m)) r -- | Get an LLVM.General.AST.'LLVM.General.AST.Module' from a LLVM.General.'Module' - i.e.@@ -219,13 +226,14 @@ return $ if s == "" then Nothing else Just s) `ap` ( do- gs <- map A.GlobalDefinition . concat <$> runInterleaved [+ gs <- map A.GlobalDefinition . concat <$> (join . liftM sequence . sequence) [ do ffiGlobals <- liftIO $ FFI.getXs (FFI.getFirstGlobal mod) FFI.getNextGlobal- forM ffiGlobals $ \g -> do+ liftM sequence . forM ffiGlobals $ \g -> do A.PointerType t as <- typeOf g- return A.GlobalVariable- `ap` getGlobalName g+ n <- getGlobalName g+ return $ return A.GlobalVariable+ `ap` return n `ap` getLinkage g `ap` getVisibility g `ap` (liftIO $ decodeM =<< FFI.isThreadLocal g)@@ -234,7 +242,6 @@ `ap` (liftIO $ decodeM =<< FFI.isGlobalConstant g) `ap` return t `ap` (do- defer i <- liftIO $ FFI.getInitializer g if i == nullPtr then return Nothing else Just <$> decodeM i) `ap` getSection g@@ -242,9 +249,10 @@ do ffiAliases <- liftIO $ FFI.getXs (FFI.getFirstAlias mod) FFI.getNextAlias- forM ffiAliases $ \a -> do- return A.G.GlobalAlias- `ap` (do n <- getGlobalName a; defer; return n)+ liftM sequence . forM ffiAliases $ \a -> do+ n <- getGlobalName a+ return $ return A.G.GlobalAlias+ `ap` return n `ap` getLinkage a `ap` getVisibility a `ap` typeOf a@@ -252,27 +260,29 @@ do ffiFunctions <- liftIO $ FFI.getXs (FFI.getFirstFunction mod) FFI.getNextFunction- forM ffiFunctions $ \f -> localScope $ do+ liftM sequence . forM ffiFunctions $ \f -> localScope $ do A.PointerType (A.FunctionType returnType _ isVarArg) _ <- typeOf f- return A.Function+ n <- getGlobalName f+ parameters <- getParameters f+ decodeBlocks <- do+ ffiBasicBlocks <- liftIO $ FFI.getXs (FFI.getFirstBasicBlock f) FFI.getNextBasicBlock+ liftM sequence . forM ffiBasicBlocks $ \b -> do+ n <- getLocalName b+ decodeInstructions <- getNamedInstructions b+ decodeTerminator <- getBasicBlockTerminator b+ return $ return A.BasicBlock `ap` return n `ap` decodeInstructions `ap` decodeTerminator+ return $ return A.Function `ap` getLinkage f `ap` getVisibility f `ap` (liftIO $ decodeM =<< FFI.getFunctionCallConv f) `ap` (liftIO $ decodeM =<< FFI.getFunctionRetAttr f) `ap` return returnType- `ap` (getGlobalName f)- `ap` ((, isVarArg) <$> getParameters f)+ `ap` return n+ `ap` return (parameters, isVarArg) `ap` (liftIO $ getFunctionAttrs f) `ap` getSection f `ap` getAlignment f- `ap` (do- ffiBasicBlocks <- liftIO $ FFI.getXs (FFI.getFirstBasicBlock f) FFI.getNextBasicBlock- runInterleaved . flip map ffiBasicBlocks $ \b -> - return A.BasicBlock- `ap` (do n <- getLocalName b; defer; return n)- `iap` getNamedInstructions b- `iap` getBasicBlockTerminator b- )+ `ap` decodeBlocks ] tds <- getStructDefinitions
src/LLVM/General/Internal/Type.hs view
@@ -14,6 +14,7 @@ import Foreign.Ptr import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI+import LLVM.General.Internal.FFI.LLVMCTypes (typeKindP) import qualified LLVM.General.Internal.FFI.Type as FFI import qualified LLVM.General.AST as A@@ -103,9 +104,9 @@ decodeM t = scopeAnyCont $ do k <- liftIO $ FFI.getTypeKind t case k of- [FFI.typeKindP|Void|] -> return A.VoidType- [FFI.typeKindP|Integer|] -> A.IntegerType <$> (decodeM =<< liftIO (FFI.getIntTypeWidth t))- [FFI.typeKindP|Function|] -> + [typeKindP|Void|] -> return A.VoidType+ [typeKindP|Integer|] -> A.IntegerType <$> (decodeM =<< liftIO (FFI.getIntTypeWidth t))+ [typeKindP|Function|] -> return A.FunctionType `ap` (decodeM =<< liftIO (FFI.getReturnType t)) `ap` (do@@ -115,27 +116,27 @@ decodeM (n, ts) ) `ap` (decodeM =<< liftIO (FFI.isFunctionVarArg t))- [FFI.typeKindP|Pointer|] ->+ [typeKindP|Pointer|] -> return A.PointerType `ap` (decodeM =<< liftIO (FFI.getElementType t)) `ap` (decodeM =<< liftIO (FFI.getPointerAddressSpace t))- [FFI.typeKindP|Half|] -> return $ A.FloatingPointType 16 A.IEEE- [FFI.typeKindP|Float|] -> return $ A.FloatingPointType 32 A.IEEE- [FFI.typeKindP|Double|] -> return $ A.FloatingPointType 64 A.IEEE- [FFI.typeKindP|FP128|] -> return $ A.FloatingPointType 128 A.IEEE- [FFI.typeKindP|X86_FP80|] -> return $ A.FloatingPointType 80 A.DoubleExtended- [FFI.typeKindP|PPC_FP128|] -> return $ A.FloatingPointType 128 A.PairOfFloats- [FFI.typeKindP|Vector|] -> + [typeKindP|Half|] -> return $ A.FloatingPointType 16 A.IEEE+ [typeKindP|Float|] -> return $ A.FloatingPointType 32 A.IEEE+ [typeKindP|Double|] -> return $ A.FloatingPointType 64 A.IEEE+ [typeKindP|FP128|] -> return $ A.FloatingPointType 128 A.IEEE+ [typeKindP|X86_FP80|] -> return $ A.FloatingPointType 80 A.DoubleExtended+ [typeKindP|PPC_FP128|] -> return $ A.FloatingPointType 128 A.PairOfFloats+ [typeKindP|Vector|] -> return A.VectorType `ap` (decodeM =<< liftIO (FFI.getVectorSize t)) `ap` (decodeM =<< liftIO (FFI.getElementType t))- [FFI.typeKindP|Struct|] -> do+ [typeKindP|Struct|] -> do let ifM c a b = c >>= \x -> if x then a else b ifM (decodeM =<< liftIO (FFI.structIsLiteral t)) (getStructure t) (saveNamedType t >> return A.NamedTypeReference `ap` getTypeName t) - [FFI.typeKindP|Array|] -> + [typeKindP|Array|] -> return A.ArrayType `ap` (decodeM =<< liftIO (FFI.getArrayLength t)) `ap` (decodeM =<< liftIO (FFI.getElementType t))