ddc-core-llvm 0.3.1.1 → 0.3.2.1

raw patch · 7 files changed

+154/−168 lines, 7 filesdep ~ddc-basedep ~ddc-coredep ~ddc-core-saltPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

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

API changes (from Hackage documentation)

Files

• DDC/Core/Llvm/Convert.hs +9/−10
• DDC/Core/Llvm/Convert/Erase.hs +1/−1
• DDC/Core/Llvm/Convert/Type.hs +15/−8
• DDC/Core/Llvm/Metadata/Graph.hs +120/−139
• DDC/Core/Llvm/Metadata/Tbaa.hs +3/−3
• LICENSE +1/−1
• ddc-core-llvm.cabal +5/−6

@@ -30,7 +30,6 @@ import qualified DDC.Core.Salt.Name             as A import qualified DDC.Core.Module                as C import qualified DDC.Core.Exp                   as C-import qualified DDC.Core.DaCon                 as C import qualified DDC.Type.Env                   as Env import qualified DDC.Core.Simplifier            as Simp import qualified Data.Map                       as Map@@ -293,7 +292,7 @@           ,  Just (A.NamePrimOp p, xs)          <- takeXPrimApps xx           ,  A.PrimControl A.PrimControlReturn  <- p           ,  [C.XType _, C.XCon _ dc]           <- xs-          ,  Just A.NameLitVoid                 <- C.takeNameOfDaCon dc+          ,  Just A.NameLitVoid                 <- takeNameOfDaCon dc           -> return  $   blocks                       |>  Block label                                 (instrs |> (annotNil $ IReturn Nothing))@@ -380,7 +379,7 @@          -- Assignment ------------------------------------           -- A statement of type void does not produce a value.-         C.XLet _ (C.LLet C.LetStrict (C.BNone t) x1) x2+         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@@ -390,18 +389,18 @@          --   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.LetStrict (C.BNone t) x1) x2+         C.XLet a (C.LLet (C.BNone t) x1) x2           | not $ isVoidT t           -> do                  n       <- newUnique                 let b   = C.BName (A.NameVar ("_dummy" ++ show n)) t                  convBodyM context kenv tenv mdsup blocks label instrs -                        (C.XLet a (C.LLet C.LetStrict b x1) x2)+                        (C.XLet a (C.LLet b x1) x2)           -- Variable assigment from a case-expression.-         C.XLet _ (C.LLet C.LetStrict b@(C.BName (A.NameVar n) t) -                                        (C.XCase _ xScrut alts)) +         C.XLet _ (C.LLet b@(C.BName (A.NameVar n) t) +                            (C.XCase _ xScrut alts))                    x2           -> do                  let t'    = convertType pp kenv t@@ -425,7 +424,7 @@                         x2           -- Variable assignment from an non-case expression.-         C.XLet _ (C.LLet C.LetStrict b@(C.BName (A.NameVar n) t) x1) x2+         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 @@ -511,7 +510,7 @@                         $ ISet vDst (XVar (Var (NameLocal n') t'))                  C.XCon _ dc-         | Just n               <- C.takeNameOfDaCon dc+         | Just n               <- takeNameOfDaCon dc          , ExpAssign vDst       <- context          -> case n of                 A.NameLitNat i@@ -682,7 +681,7 @@                 return  $  AltDefault label blocks           C.AAlt (C.PData dc []) x-          | Just n      <- C.takeNameOfDaCon dc+          | 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

@@ -7,7 +7,7 @@ where import DDC.Type.Predicates import DDC.Core.Exp-import DDC.Core.Transform.TransformX+import DDC.Core.Transform.TransformUpX   -- | Erase type and witness arge Slurp out only the values from a list of

@@ -44,7 +44,9 @@         -- represented as a generic boxed object.         C.TVar u          -> case Env.lookup u kenv of-             Nothing            -> die $ "Type variable not in kind environment." ++ show u+             Nothing            +              -> die $ "Type variable not in kind environment." ++ show u+              Just k               | isDataKind k    -> TPointer (tObj pp)               | otherwise       -> die "Invalid type variable."@@ -155,13 +157,13 @@                  PrimTyConFloat bits                  -> case bits of-                        32              -> TFloat-                        64              -> TDouble-                        80              -> TFloat80-                        128             -> TFloat128-                        _               -> die "Invalid width for float type constructor."+                        32      -> TFloat+                        64      -> TDouble+                        80      -> TFloat80+                        128     -> TFloat128+                        _       -> die "Invalid width for float type constructor." -                _                       -> die "Invalid primitive type constructor."+                _               -> die "Invalid primitive type constructor."          _ -> die "Invalid type constructor." @@ -179,18 +181,22 @@ tPtr :: Type -> Type tPtr t = TPointer t + -- | Alias for address type. tAddr :: Platform -> Type tAddr pp = TInt (8 * platformAddrBytes pp) + -- | Alias for natural numner type. tNat :: Platform -> Type tNat pp = TInt (8 * platformAddrBytes pp) + -- | Alias for machine integer type. tInt :: Platform -> Type tInt pp = TInt (8 * platformAddrBytes pp) + -- | Alias for address type. tTag :: Platform -> Type tTag pp = TInt (8 * platformTagBytes  pp)@@ -199,7 +205,8 @@ -- Predicates ----------------------------------------------------------------- -- | Check whether this is the Void# type. isVoidT :: C.Type A.Name -> Bool-isVoidT (C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon A.PrimTyConVoid) _) _)) = True+isVoidT (C.TCon (C.TyConBound (C.UPrim (A.NamePrimTyCon A.PrimTyConVoid) _) _)) +         = True isVoidT _ = False  

@@ -1,30 +1,21 @@ -- Manipulate graphs for metadata generation---  WARNING: everything in here is REALLY SLOW+{-# LANGUAGE TupleSections #-} module DDC.Core.Llvm.Metadata.Graph        ( -- * Graphs and Trees for TBAA metadata          UG(..), DG(..)-       , minOrientation, partitionDG+       , orientUG, partitionDG        , Tree(..)        , sources, anchor            -- * Quickcheck Testing ONLY        , Dom, Rel        , fromList, toList-       , allR, differenceR, unionR, composeR, transitiveR-       , transClosure, transReduction-       , aliasMeasure, isTree -       , orientation, orientations-       , bruteforceMinOrientation-       , transOrientation-       , smallOrientation-       , partitionings       -       , minimumCompletion )+       , transClosure, transOrient+       , aliasMeasure, isTree ) where-import Data.List          hiding (partition)+import Data.List  import Data.Ord-import Data.Tuple import Data.Maybe-import Control.Monad   -- Binary relations -----------------------------------------------------------@@ -43,37 +34,9 @@ fromList s = \x y -> (x,y) `elem` s  --- | Get the size of a a relation.-size :: Dom a -> Rel a -> Int-size d r = length $ toList d r----- | The universal negative relation.---   All members of the domain are not related.-allR :: Eq a => Rel a-allR = (/=)----- | Fifference of two relations.-differenceR :: Rel a -> Rel a -> Rel a-differenceR     f g = \x y -> f x y && not (g x y)-- -- | Union two relations. unionR :: Rel a -> Rel a -> Rel a-unionR          f g = \x y -> f x y || g x y----- | Compose two relations.-composeR :: Dom a -> Rel a -> Rel a -> Rel a-composeR dom f g = \x y -> or [ f x z && g z y | z <- dom ]----- | Check whether a relation is transitive.-transitiveR :: Dom a -> Rel a -> Bool-transitiveR dom r- = and [ not (r x y  && r y z && not (r x z)) -       | x <- dom, y <- dom, z <- dom ]+unionR f g = \x y -> f x y || g x y   -- | Find the transitive closure of a binary relation@@ -88,16 +51,6 @@                                 , b == c])  --- | Get the size of the transitive closure of a relation.-transCloSize :: (Eq a) => Dom a -> Rel a -> Int-transCloSize d r = size d $ transClosure d r--transReduction :: Eq a => Dom a -> Rel a -> Rel a-transReduction dom rel -  = let composeR' = composeR dom-    in  rel `differenceR` (rel `composeR'` transClosure dom rel)-- -- Graphs --------------------------------------------------------------------- -- | An undirected graph. newtype UG  a = UG (Dom a, Rel a)@@ -114,74 +67,132 @@ instance Show a => Eq (DG a) where   a == b = show a == show b  +neighbourUG :: Rel a -> a -> a -> Bool+neighbourUG f v x = f v x  || f x v --- | Find the transitive orientation of an undirected graph if one exists-------   ISSUE #297: Taking the transitive orientation of an aliasing graph---    takes exponential(?) time. We should implement the O(n+m) algorithm---    or detect when this is taking too long and bail out.----transOrientation :: Eq a => UG a -> Maybe (DG a)-transOrientation ug@(UG (d,_))-  = liftM DG -  $ liftM (d,) -  $ find (transitiveR d) -  $ orientations ug -orientations :: Eq a => UG a -> [Rel a]-orientations (UG (d,g))-  = case toList d g of-        []    -> [g]-        edges -> let combo k      = filter ((k==) . length) $ subsequences edges-                     choices      = concatMap combo [0..length d]-                     choose c     = g `differenceR` fromList c-                                      `unionR`      fromList (map swap c)-                  in map choose choices+-- | A partition (class) of vertices+type Class a = [a]  --- | Find the orientation with the smallest transitive closure----minOrientation :: (Show a, Eq a) => UG a -> DG a-minOrientation ug = fromMaybe (bruteforceMinOrientation ug) (transOrientation ug)+-- | Enforce an ordering on the relation of an undirected graph+forceOrder :: Ord a => Class a -> Rel a -> Rel a +forceOrder ordering f +  = let index = fromJust . (flip elemIndex ordering) +    in  \x y -> neighbourUG f x y && index x < index y -bruteforceMinOrientation :: (Show a, Eq a) => UG a -> DG a-bruteforceMinOrientation ug@(UG (d, _))-  = let minTransClo : _ = sortBy (comparing $ transCloSize d)-                        $ orientations ug-     in DG (d, minTransClo) +-- | Set of vertices is not a singleton or empty set+nonSingleton :: Class a -> Bool+nonSingleton []  = False+nonSingleton [_] = False+nonSingleton _   = True --- | Find the orientation with a `small enough' transitive closure----smallOrientation :: (Show a, Eq a) => UG a -> DG a-smallOrientation ug = fromMaybe (orientation ug) (transOrientation ug)+                      +-- | 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]+  where refine acc classes+          | any nonSingleton classes = pivot acc classes+          | otherwise                = concat classes ++ acc -orientation :: Eq a => UG a -> DG a-orientation (UG (d,g)) = DG (d,g)+        pivot acc ([vertex]:classes)    = refine (vertex:acc) $ classes      `splitAllOn` vertex+        pivot acc ((vertex:vs):classes) = refine (vertex:acc) $ (vs:classes) `splitAllOn` vertex+        pivot _   _                     = error "impossible!" +        splitAllOn [] _ = []+        splitAllOn (cl:classes) vertex+          | (neighbours, nonneighbours) <- partition (neighbourUG f vertex) cl+          , all (not . null) [neighbours, nonneighbours]+          = nonneighbours : neighbours : (classes `splitAllOn` vertex)+          | otherwise +          = cl                         : (classes `splitAllOn` vertex) --- | Add a minimum number of edges to an undirected graph such that---    it has a transitive orientation++-- | Transitively orient an undireted graph ---minimumCompletion :: (Show a, Eq a) => UG a -> UG a-minimumCompletion (UG (d,g))- = let -       -- Let U be the set of all possible fill edges. For all subsets-       --   S of U, add S to G and see if the result is trans-orientable.-       u           = toList d $ allR `differenceR` g-       combo k     = filter ((k==) . length) $ subsequences u-       choices     = concatMap combo [0..length u]-       choose c    = g `unionR` fromList c+--      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+--+--      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))+  = let vertices' = refine $ [(lexBFS g, maxBound)]+    in  DG (vertices, forceOrder vertices' f)+  where refine classes +          | any nonSingleton $ map fst classes+          = let (before, after) = partition (\(c,lastused) -> length c > lastused `div` 2) classes+            in  refine (splitOthers before after)+          | otherwise = concatMap fst classes+        +        -- Split all other classes with respect to each member of a pivot class+        splitOthers before [] = splitLargest (largestClass before) before+        splitOthers before ((pivot,_):after)+          =    foldl' (split True) before pivot +            ++ [(pivot, length pivot)] +            ++ foldl' (split False) after pivot -       -- There always exists a comparability completion for an undirected graph-       --   in the worst case it's the complete version of the graph.-       --   the result is minimum thanks to how `subsequences` and-       --   list comprehensions work.-   in  fromMaybe (error "minimumCompletion: no completion found!") -                $ liftM UG -                $ find (isJust . transOrientation . UG) $ map ((d,) . choose) choices+        -- Split a class cl with regard to some vertex+        split _ [] _ = []+        split isBefore (cl:classes) vertex+          | (neighbours, nonneighbours) <- partition (neighbourUG f vertex) $ fst cl+          , 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)+          | otherwise = cl:classes +        -- Split the largest class by the last vertex in the class found by lexBFS+        splitLargest _ [] = []+        splitLargest cl ((cs, lastused):css)+          | cl == cs  = (tail cs, lastused) : ([head cs], maxBound) : css+          | otherwise = (cs, lastused) : (splitLargest cl css) +        largestClass []      = []+        largestClass classes = maximumBy (comparing length) $ map fst classes+         ++orientUG :: (Show a, Ord a) => UG a -> DG a+orientUG = transOrient+++-- | A vertex partitioning of a graph.+type Partitioning a = [Class a]+++-- | Generate all possible partitions of a list+--    by nondeterministically decide which sublist to add an element to.+partitionings :: Eq a => [a] -> [Partitioning a]+partitionings []     = [[]]+partitionings (x:xs) = concatMap (nondetPut x) $ partitionings xs+  where nondetPut :: a -> Partitioning a -> [Partitioning a]+        nondetPut y []     = [ [[y]] ]+        nondetPut y (l:ls) = let putHere  = (y:l):ls+                                 putLater = map (l:) $ nondetPut y ls+                              in putHere:putLater+++-- | Calculate the aliasing induced by a set of trees this includes aliasing+--   within each of the trees and aliasing among trees.+---+--   ISSUE #298: Need a more efficient way to compute the+--     aliasing measure. Currently O(|V|^5)+--+aliasMeasure :: Eq a => Rel a -> Partitioning a -> Int+aliasMeasure g p+ = (outerAliasing $ map length p) + (sum $ map innerAliasing p)+    where innerAliasing t = length $ toList t $ transClosure t g+          outerAliasing (l:ls) = l * (sum ls) + outerAliasing ls+          outerAliasing []     = 0    ++ -- Trees ---------------------------------------------------------------------- -- | An inverted tree (with edges going from child to parent) newtype Tree a = Tree (Dom a, Rel a)@@ -213,41 +224,11 @@                $ sortBy (comparing (aliasMeasure g))                $ partitionings d ---- | A partitioning of a tree.-type Partitioning a = [SubList a]-type SubList a      = [a]----- | Calculate the aliasing induced by a set of trees this includes aliasing---   within each of the trees and aliasing among trees.-------   ISSUE #298: Need a more efficient way to compute the---     aliasing measure. What is the complexity of this current version?----aliasMeasure :: Eq a => Rel a -> Partitioning a -> Int-aliasMeasure g p- = (outerAliasing $ map length p) + (sum $ map innerAliasing p)-    where innerAliasing t = length $ toList t $ transClosure t g-          outerAliasing (l:ls) = l * (sum ls) + outerAliasing ls-          outerAliasing []     = 0----- | Generate all possible partitions of a list---    by nondeterministically decide which sublist to add an element to.-partitionings :: Eq a => [a] -> [Partitioning a]-partitionings []     = [[]]-partitionings (x:xs) = concatMap (nondetPut x) $ partitionings xs-  where nondetPut :: a -> Partitioning a -> [Partitioning a]-        nondetPut y []     = [ [[y]] ]-        nondetPut y (l:ls) = let putHere  = (y:l):ls-                                 putLater = map (l:) $ nondetPut y ls-                              in putHere:putLater-                 -        +                     -- | Enroot a tree with the given root. anchor :: Eq a => a -> Tree a -> Tree a anchor root (Tree (d,g))   = let leaves = filter (null . flip filter d . g) d         arcs   = map (, root) leaves     in  Tree (root:d, g `unionR` fromList arcs)+

@@ -83,7 +83,7 @@         (constwits, diswits) = partitionWits $ collectWitsB xx         arel                 = constructARel   diswits         domain               = constructANodes regs constwits-        mdDG                 = minOrientation $ UG (domain, arel)+        mdDG                 = orientUG $ UG (domain, arel)         mdTrees              = partitionDG mdDG     in  foldM (buildMDTree nTop) (MDSuper emptyDict []) mdTrees @@ -144,9 +144,9 @@ -- Alias relation ------------------------------------------------------------- -- | A node in the alias graphs, representing a region data ANode  = ANode { regionU :: RegBound-                   , isConst :: Bool }+                    , isConst :: Bool }             | ARoot-              deriving (Show, Eq)+              deriving (Show, Eq, Ord)   -- | Make nodes from regions

@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2012 The Disciplined Disciple Compiler Strike Force+Copyrite (K) 2007-2013 The Disciplined Disciple Compiler Strike Force All rights reversed.  Permission is hereby granted, free of charge, to any person obtaining a copy

@@ -1,5 +1,5 @@ Name:           ddc-core-llvm-Version:        0.3.1.1+Version:        0.3.2.1 License:        MIT License-file:   LICENSE Author:         The Disciplined Disciple Compiler Strike Force@@ -9,7 +9,6 @@ Stability:      experimental Category:       Compilers/Interpreters Homepage:       http://disciple.ouroborus.net-Bug-reports:    disciple@ouroborus.net Synopsis:       Disciplined Disciple Compiler LLVM code generator. Description:    Disciplined Disciple Compiler LLVM code generator. @@ -20,10 +19,10 @@         array           == 0.4.*,         transformers    == 0.3.*,         mtl             == 2.1.*,-        ddc-base        == 0.3.1.*,-        ddc-core        == 0.3.1.*,-        ddc-core-simpl  == 0.3.1.*,-        ddc-core-salt   == 0.3.1.*+        ddc-base        == 0.3.2.*,+        ddc-core        == 0.3.2.*,+        ddc-core-simpl  == 0.3.2.*,+        ddc-core-salt   == 0.3.2.*    Exposed-modules:         DDC.Core.Llvm.Metadata.Graph