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 @@ -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 diff --git a/DDC/Core/Llvm/Convert/Erase.hs b/DDC/Core/Llvm/Convert/Erase.hs --- a/DDC/Core/Llvm/Convert/Erase.hs +++ b/DDC/Core/Llvm/Convert/Erase.hs @@ -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 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 @@ -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 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 @@ -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) + 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 @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 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.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