├── Grin.cabal ├── LICENSE ├── Setup.hs ├── cbits └── lookup3.c ├── src ├── C │ ├── FFI.hs │ ├── FromGrin2.hs │ ├── Generate.hs │ └── Prims.hs ├── Cmm │ ├── Number.hs │ └── Op.hs ├── Doc │ ├── Chars.hs │ ├── DocLike.hs │ ├── PPrint.hs │ └── Pretty.hs ├── Fixer │ ├── Fixer.hs │ └── Supply.hs ├── FlagDump.hs ├── FlagOpts.hs ├── GenUtil.hs ├── Grin │ ├── DeadCode.hs │ ├── Devolve.hs │ ├── EvalInline.hs │ ├── Grin.hs │ ├── Grin.hs-boot │ ├── HashConst.hs │ ├── Lint.hs │ ├── Main.hs │ ├── NodeAnalyze.hs │ ├── Noodle.hs │ ├── Optimize.hs │ ├── SSimplify.hs │ ├── Show.hs │ ├── Show.hs-boot │ ├── StorageAnalysis.hs │ ├── Val.hs │ └── Whiz.hs ├── Info │ └── Info.hs ├── Name │ ├── Internals.hs │ ├── Name.hs │ ├── Names.hs │ ├── Prim.hs │ └── VConsts.hs ├── Options.hs ├── PackedString.hs ├── RawFiles.hs ├── Stats.hs ├── StringTable │ ├── Atom.hsc │ ├── StringTable_cbits.c │ └── StringTable_cbits.h ├── Support │ ├── CanType.hs │ ├── Compat.hs │ ├── FreeVars.hs │ ├── IniParse.hs │ ├── TempDir.hs │ ├── Tickle.hs │ └── Transform.hs ├── Ty │ └── Level.hs ├── Util │ ├── ExitCodes.hs │ ├── GMap.hs │ ├── Gen.hs │ ├── Graph.hs │ ├── Graphviz.hs │ ├── HasSize.hs │ ├── IntBag.hs │ ├── Once.hs │ ├── Perhaps.hs │ ├── SetLike.hs │ ├── Std.hs │ ├── UnionFind.hs │ ├── UnionSolve.hs │ ├── UniqueMonad.hs │ └── YAML.hs └── Version │ ├── Config.hs │ ├── Config.hs.in │ └── Version.hs └── stack.yaml /Grin.cabal: -------------------------------------------------------------------------------- 1 | -- Initial Grin.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: Grin 5 | version: 0.1.0.0 6 | synopsis: grin backend stripped out from jhc 7 | description: Compiles grin to C or executable. Also includes the jhc rts. 8 | -- license: 9 | license-file: LICENSE 10 | author: John Meacham 11 | --maintainer: 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | cabal-version: >=1.10 16 | 17 | extra-source-files: 18 | src/StringTable/StringTable_cbits.h 19 | src/StringTable/StringTable_cbits.c 20 | 21 | library 22 | exposed-modules: Grin.Main 23 | Grin.Grin 24 | Grin.DeadCode 25 | Grin.Devolve 26 | Grin.EvalInline 27 | Grin.HashConst 28 | Grin.Lint 29 | Grin.NodeAnalyze 30 | Grin.Noodle 31 | Grin.Optimize 32 | Grin.Show 33 | Grin.SSimplify 34 | Grin.StorageAnalysis 35 | Grin.Val 36 | Grin.Whiz 37 | 38 | other-modules: FlagDump 39 | FlagOpts 40 | GenUtil 41 | Options 42 | PackedString 43 | RawFiles 44 | Stats 45 | C.FFI 46 | C.FromGrin2 47 | C.Generate 48 | C.Prims 49 | Cmm.Number 50 | Cmm.Op 51 | Doc.Chars 52 | Doc.DocLike 53 | Doc.PPrint 54 | Doc.Pretty 55 | Fixer.Fixer 56 | Fixer.Supply 57 | Info.Info 58 | Name.Internals 59 | Name.Name 60 | Name.Names 61 | Name.Prim 62 | Name.VConsts 63 | StringTable.Atom 64 | Support.CanType 65 | Support.Compat 66 | Support.FreeVars 67 | Support.IniParse 68 | Support.TempDir 69 | Support.Tickle 70 | Support.Transform 71 | Ty.Level 72 | Util.ExitCodes 73 | Util.Gen 74 | Util.GMap 75 | Util.Graph 76 | Util.Graphviz 77 | Util.HasSize 78 | Util.IntBag 79 | Util.Once 80 | Util.Perhaps 81 | Util.SetLike 82 | Util.Std 83 | Util.UnionFind 84 | Util.UnionSolve 85 | Util.UniqueMonad 86 | Util.YAML 87 | Version.Config 88 | Version.Version 89 | 90 | extensions: PatternGuards 91 | DeriveGeneric 92 | 93 | build-depends: base >=4.8 && <5, 94 | containers, 95 | old-time, 96 | mtl, 97 | directory, 98 | utf8-string, 99 | binary, 100 | syb, 101 | bytestring, 102 | filepath, 103 | pretty, 104 | process, 105 | fgl, 106 | unix, 107 | array, 108 | random 109 | hs-source-dirs: src 110 | build-tools: hsc2hs 111 | default-language: Haskell98 112 | ghc-options: -fno-warn-tabs 113 | include-dirs: src/StringTable 114 | c-sources: src/StringTable/StringTable_cbits.c 115 | cbits/lookup3.c 116 | 117 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013 John Meacham 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /src/C/FFI.hs: -------------------------------------------------------------------------------- 1 | {- Generated by DrIFT (Automatic class derivations for Haskell) -} 2 | {-# LINE 1 "src/C/FFI.hs" #-} 3 | module C.FFI( 4 | CallConv(..), 5 | Safety(..), 6 | FfiType(..), 7 | FfiExport(..), 8 | FfiSpec(..), 9 | Requires(..) 10 | ) where 11 | 12 | import C.Prims 13 | import Data.Binary 14 | import Data.Typeable 15 | 16 | type CName = String 17 | 18 | data FfiType = Import CName Requires 19 | | ImportAddr CName Requires 20 | | Wrapper 21 | | Dynamic 22 | deriving(Eq,Ord,Show) 23 | 24 | data FfiSpec = FfiSpec FfiType Safety CallConv 25 | deriving(Eq,Ord,Show) 26 | 27 | data FfiExport = FfiExport { 28 | ffiExportCName :: CName, 29 | ffiExportSafety :: Safety, 30 | ffiExportCallConv :: CallConv, 31 | ffiExportArgTypes :: [ExtType], 32 | ffiExportRetType :: ExtType 33 | } 34 | deriving(Eq,Ord,Show,Typeable) 35 | {-! derive: Binary !-} 36 | {-* Generated by DrIFT : Look, but Don't Touch. *-} 37 | instance Data.Binary.Binary FfiExport where 38 | put (FfiExport aa ab ac ad ae) = do 39 | Data.Binary.put aa 40 | Data.Binary.put ab 41 | Data.Binary.put ac 42 | Data.Binary.put ad 43 | Data.Binary.put ae 44 | get = do 45 | aa <- get 46 | ab <- get 47 | ac <- get 48 | ad <- get 49 | ae <- get 50 | return (FfiExport aa ab ac ad ae) 51 | 52 | -- Imported from other files :- 53 | -------------------------------------------------------------------------------- /src/Cmm/Number.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Cmm.Number(Number(..),toIntegral) where 3 | 4 | import Data.Binary 5 | import Data.Ratio 6 | 7 | newtype Number = Number Rational 8 | deriving(Num,Eq,Ord,Binary,Real,Fractional,RealFrac,Enum) 9 | 10 | instance Integral Number where 11 | toInteger (Number x) = case denominator x of 12 | 1 -> numerator x 13 | _ -> error $ "toInteger: Number not integer " ++ show x 14 | quotRem x y = case toInteger x `quotRem` toInteger y of 15 | (x,y) -> (fromInteger x,fromInteger y) 16 | 17 | instance Show Number where 18 | showsPrec n (Number r) = case denominator r of 19 | 1 -> showsPrec n (numerator r) 20 | _ -> showsPrec n (realToFrac r :: Double) 21 | 22 | toIntegral :: (Integral i,Monad m) => Number -> m i 23 | toIntegral (Number r) = case denominator r of 24 | 1 -> return $ fromInteger (numerator r) 25 | _ -> fail $ "toInteger: Number not integer " ++ show r 26 | -------------------------------------------------------------------------------- /src/Doc/Chars.hs: -------------------------------------------------------------------------------- 1 | -- | A variety of useful constant documents representing many unicode characters. 2 | 3 | module Doc.Chars where 4 | 5 | import Data.Char(chr) 6 | import Doc.DocLike 7 | 8 | ulCorner, llCorner, urCorner, lrCorner, rTee, lTee, bTee, tTee, hLine, 9 | vLine, plus, s1, s9, diamond, ckBoard, degree, plMinus, bullet, lArrow, 10 | rArrow, dArrow, uArrow, board, lantern, block, s3, s7, lEqual, gEqual, 11 | pi, nEqual, sterling, coloncolon, alpha, beta, lambda, forall, exists, 12 | box, bot, bottom, top, pI, lAmbda, star, elem, notElem, and, or, sqoparen, sqcparen :: TextLike a => a 13 | 14 | ulCorner = char $ chr 0x250C 15 | llCorner = char $ chr 0x2514 16 | urCorner = char $ chr 0x2510 17 | lrCorner = char $ chr 0x2518 18 | rTee = char $ chr 0x2524 19 | lTee = char $ chr 0x251C 20 | bTee = char $ chr 0x2534 21 | tTee = char $ chr 0x252C 22 | hLine = char $ chr 0x2500 23 | vLine = char $ chr 0x2502 24 | plus = char $ chr 0x253C 25 | s1 = char $ chr 0x23BA -- was: 0xF800 26 | s9 = char $ chr 0x23BD -- was: 0xF804 27 | diamond = char $ chr 0x25C6 28 | ckBoard = char $ chr 0x2592 29 | degree = char $ chr 0x00B0 30 | plMinus = char $ chr 0x00B1 31 | bullet = char $ chr 0x00B7 32 | lArrow = char $ chr 0x2190 33 | rArrow = char $ chr 0x2192 34 | dArrow = char $ chr 0x2193 35 | uArrow = char $ chr 0x2191 36 | board = char $ chr 0x2591 37 | lantern = char $ chr 0x256C 38 | block = char $ chr 0x2588 39 | s3 = char $ chr 0x23BB -- was: 0xF801 40 | s7 = char $ chr 0x23BC -- was: 0xF803 41 | lEqual = char $ chr 0x2264 42 | gEqual = char $ chr 0x2265 43 | pi = char $ chr 0x03C0 44 | nEqual = char $ chr 0x2260 45 | sterling = char $ chr 0x00A3 46 | 47 | coloncolon = char $ chr 0x2237 -- ∷ 48 | 49 | alpha = char $ chr 0x03b1 -- α 50 | beta = char $ chr 0x03b2 -- β 51 | 52 | 53 | lambda = char $ chr 0x03bb -- λ 54 | forall = char $ chr 0x2200 -- ∀ 55 | exists = char $ chr 0x2203 -- ∃ 56 | box = char $ chr 0x25a1 -- □ 57 | 58 | bot = char $ chr 0x22a5 -- ⊥ 59 | bottom = char $ chr 0x22a5 -- ⊥ 60 | top = char $ chr 0x22a4 -- T 61 | pI = char $ chr 0x03a0 62 | lAmbda = char $ chr 0x039b -- Λ (capital λ) 63 | and = char $ chr 0x2227 -- ∧ 64 | or = char $ chr 0x2228 -- ∨ 65 | star = char $ chr 0x22c6 66 | elem = char $ chr 0x2208 -- ∈ 67 | notElem = char $ chr 0x2209 68 | 69 | sqoparen = char $ chr 0x3014 -- 〔 70 | sqcparen = char $ chr 0x3015 -- 〕 71 | 72 | -------------------------------------------------------------------------------- /src/Doc/DocLike.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP,UndecidableInstances,OverlappingInstances, TypeSynonymInstances, FlexibleInstances #-} 2 | module Doc.DocLike where 3 | 4 | -- #include "hs_src_config.h" 5 | #define HAS_MONOID_DOC 1 6 | -- arch-tag: a88f19fb-e18d-475f-b6d1-8da78676261a 7 | 8 | #if !HAS_MONOID_DOC 9 | import Data.Monoid(Monoid(..)) 10 | #endif 11 | import Control.Monad.Reader() 12 | import qualified Text.PrettyPrint.HughesPJ as P 13 | 14 | infixr 5 <$> -- ,,<$>,<$$> 15 | infixr 6 <> 16 | infixr 6 <+> 17 | 18 | class TextLike a where 19 | empty :: a 20 | text :: String -> a 21 | --string :: String -> a 22 | char :: Char -> a 23 | --char '\n' = string "\n" 24 | char x = text [x] 25 | empty = text "" 26 | 27 | class (TextLike a) => DocLike a where 28 | (<>) :: a -> a -> a 29 | (<+>) :: a -> a -> a 30 | (<$>) :: a -> a -> a 31 | hsep :: [a] -> a 32 | hcat :: [a] -> a 33 | vcat :: [a] -> a 34 | tupled :: [a] -> a 35 | list :: [a] -> a 36 | semiBraces :: [a] -> a 37 | enclose :: a -> a -> a -> a 38 | encloseSep :: a -> a -> a -> [a] -> a 39 | 40 | hcat [] = empty 41 | hcat xs = foldr1 (<>) xs 42 | hsep [] = empty 43 | hsep xs = foldr1 (<+>) xs 44 | vcat [] = empty 45 | vcat xs = foldr1 (\x y -> x <> char '\n' <> y) xs 46 | x <+> y = x <> char ' ' <> y 47 | x <$> y = x <> char '\n' <> y 48 | encloseSep l r s ds = enclose l r (hcat $ punctuate s ds) 49 | enclose l r x = l <> x <> r 50 | list = encloseSep lbracket rbracket comma 51 | tupled = encloseSep lparen rparen comma 52 | semiBraces = encloseSep lbrace rbrace semi 53 | 54 | ------------------------ 55 | -- Basic building blocks 56 | ------------------------ 57 | 58 | tshow :: (Show a,DocLike b) => a -> b 59 | tshow x = text (show x) 60 | 61 | lparen,rparen,langle,rangle, 62 | lbrace,rbrace,lbracket,rbracket,squote, 63 | dquote,semi,colon,comma,space,dot,backslash,equals 64 | :: TextLike a => a 65 | lparen = char '(' 66 | rparen = char ')' 67 | langle = char '<' 68 | rangle = char '>' 69 | lbrace = char '{' 70 | rbrace = char '}' 71 | lbracket = char '[' 72 | rbracket = char ']' 73 | 74 | squote = char '\'' 75 | dquote = char '"' 76 | semi = char ';' 77 | colon = char ':' 78 | comma = char ',' 79 | space = char ' ' 80 | dot = char '.' 81 | backslash = char '\\' 82 | equals = char '=' 83 | 84 | squotes x = enclose squote squote x 85 | dquotes x = enclose dquote dquote x 86 | parens x = enclose lparen rparen x 87 | braces x = enclose lbrace rbrace x 88 | brackets x = enclose lbracket rbracket x 89 | angles x = enclose langle rangle x 90 | 91 | ----------------------------------------------------------- 92 | -- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn] 93 | ----------------------------------------------------------- 94 | punctuate _ [] = [] 95 | punctuate _ [d] = [d] 96 | punctuate p (d:ds) = (d <> p) : punctuate p ds 97 | 98 | ------------------ 99 | -- String instance 100 | ------------------ 101 | instance TextLike String where 102 | empty = "" 103 | text x = x 104 | 105 | instance TextLike Char where 106 | empty = error "TextLike: empty char" 107 | char x = x 108 | text [ch] = ch 109 | text _ = error "TextLike: string to char" 110 | 111 | instance DocLike String where 112 | a <> b = a ++ b 113 | a <+> b = a ++ " " ++ b 114 | 115 | instance TextLike ShowS where 116 | empty = id 117 | text x = (x ++) 118 | char c = (c:) 119 | 120 | instance DocLike ShowS where 121 | a <> b = a . b 122 | 123 | instance (TextLike a, Monad m) => TextLike (m a) where 124 | empty = return empty 125 | char x = return (char x) 126 | text x = return (text x) 127 | 128 | instance (DocLike a, Monad m,TextLike (m a)) => DocLike (m a) where 129 | a <$> b = do 130 | a <- a 131 | b <- b 132 | return (a Doc.DocLike.<$> b) 133 | a <> b = do 134 | a <- a 135 | b <- b 136 | return (a <> b) 137 | a <+> b = do 138 | a <- a 139 | b <- b 140 | return (a <+> b) 141 | vcat xs = sequence xs >>= return . vcat 142 | hsep xs = sequence xs >>= return . hsep 143 | 144 | --------------------- 145 | -- HughesPJ instances 146 | --------------------- 147 | 148 | instance TextLike P.Doc where 149 | empty = P.empty 150 | text = P.text 151 | char = P.char 152 | 153 | #if !HAS_MONOID_DOC 154 | instance Monoid P.Doc where 155 | mappend = (P.<>) 156 | mempty = P.empty 157 | mconcat = P.hcat 158 | #endif 159 | 160 | instance DocLike P.Doc where 161 | (<>) = (P.<>) 162 | (<+>) = (P.<+>) 163 | (<$>) = (P.$$) 164 | hsep = P.hsep 165 | vcat = P.vcat 166 | 167 | --brackets = P.brackets 168 | --parens = P.parens 169 | 170 | -------- 171 | -- simple instances to allow distribution of an environment 172 | -------- 173 | --instance Monoid a => Monoid (b -> a) where 174 | -- mempty = \_ -> mempty 175 | -- mappend x y = \a -> mappend (x a) (y a) 176 | -- mconcat xs = \a -> mconcat (map ($ a) xs) 177 | -- 178 | --instance (DocLike a, Monoid (b -> a)) => DocLike (b -> a) where 179 | -- parens x = \a -> parens (x a) 180 | -- (<+>) x y = \a -> x a <+> y a 181 | -------------------------------------------------------------------------------- /src/Doc/PPrint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} 2 | -- | A Pretty printing class using multiparameter type classes for 3 | -- maximal generality with some useful instances. 4 | -- 5 | -- the pprinted type comes as the last argument so newtype deriving can be used 6 | -- in more places. 7 | 8 | module Doc.PPrint where 9 | 10 | import Doc.DocLike 11 | import qualified Data.Map as Map 12 | 13 | {- 14 | - some useful fixities for comparison 15 | - 16 | - application left 10 17 | - infixr 9 . 18 | - infixr 8 ^, ^^, ** 19 | - infixl 7 * , /, `quot`, `rem`, `div`, `mod` 20 | - infixl 6 +, - 21 | - infixr 5 : 22 | - infix 4 ==, /=, <, <=, >=, > 23 | - infixr 3 && 24 | - infixr 2 || 25 | - infixl 1 >>, >>= 26 | - infixr 1 =<< 27 | - infixr 0 $, $!, `seq` 28 | - 29 | -} 30 | 31 | data Assoc = AssocLeft | AssocRight | AssocNone 32 | deriving(Eq,Ord,Show) 33 | 34 | class DocLike d => PPrint d a where 35 | pprint :: a -> d 36 | pprintAssoc :: Assoc -> Int -> a -> d 37 | 38 | pprintAssoc _ _ a = pprint a 39 | pprint a = pprintAssoc AssocNone (-1) a 40 | 41 | 42 | pplist :: [a] -> d 43 | pplist xs = brackets (hcat (punctuate comma (map pprint xs))) 44 | 45 | pprintParen :: PPrint d a => a -> d 46 | pprintParen = pprintPrec 11 47 | 48 | pprintPrec n a = pprintAssoc AssocNone n a 49 | 50 | instance PPrint d a => PPrint d [a] where 51 | pprint = pplist 52 | 53 | instance DocLike d => PPrint d Char where 54 | pprint = char 55 | pplist = text 56 | 57 | instance DocLike d => PPrint d Integer where 58 | pprint = tshow 59 | 60 | instance DocLike d => PPrint d Int where 61 | pprint = tshow 62 | 63 | instance DocLike d => PPrint d Float where 64 | pprint = tshow 65 | 66 | instance DocLike d => PPrint d Double where 67 | pprint = tshow 68 | 69 | instance DocLike d => PPrint d () where 70 | pprint () = text "()" 71 | 72 | instance (PPrint d a, PPrint d b) => PPrint d (a,b) where 73 | pprint (x,y) = parens (hsep [pprint x <> comma, pprint y]) 74 | 75 | checkAssoc a1 n1 a2 n2 | n2 < n1 = id 76 | | n1 == n2 && a1 == a2 && a1 /= AssocNone = id 77 | | otherwise = parens 78 | 79 | checkAssocApp a n p = checkAssoc AssocLeft 10 a n p 80 | 81 | pprintBinary a1 n1 a2 n2 x1 b x2 = checkAssoc a1 n1 a2 n2 $ pprintAssoc l n1 x1 <+> b <+> pprintAssoc r n1 x2 where 82 | l = if a1 == AssocLeft then AssocLeft else AssocNone 83 | r = if a1 == AssocRight then AssocRight else AssocNone 84 | 85 | instance (PPrint d a, PPrint d b) => PPrint d (Either a b) where 86 | pprintAssoc a n (Left x) = checkAssocApp a n $ text "Left" <+> pprintPrec 10 x 87 | pprintAssoc a n (Right x) = checkAssocApp a n $ text "Right" <+> pprintPrec 10 x 88 | 89 | instance (PPrint d a, PPrint d b, PPrint d c) => PPrint d (a,b,c) where 90 | pprint (x,y,z) = parens (hsep [pprint x <> comma, 91 | pprint y <> comma, 92 | pprint z]) 93 | 94 | instance (PPrint d a, PPrint d b) => PPrint d (Map.Map a b) where 95 | pprint m = vcat [ pprint x <+> text "=>" <+> pprint y | (x,y) <- Map.toList m] 96 | 97 | 98 | -------------------------------------------------------------------------------- /src/Fixer/Fixer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, ExistentialQuantification #-} 2 | -- find fixpoint of constraint problem 3 | 4 | {- 2009.01.05: Lemmih 5 | 6 | This may be obvious to a lot of people but it certainly wasn't obvious to me. 7 | 8 | The following module help you solve problems that involve iterating over 9 | a piece of data until some steady-state (aka. a fixpoint) is found. 10 | 11 | One example problem would be dead-code elimination. To remove all dead 12 | functions and function arguments, we have to mark everything that 13 | could possibly be alive (we necessarily have to be conservative). 14 | This is done in two steps: 15 | 1) Walk through the code and make a note of all the dependencies 16 | (eg. function 'x' uses function 'y' and function 'z'). The dependencies 17 | are then handed over to the fixpoint solver. 18 | 2) The fixpoint solver iterate over all the data and use the dependencies 19 | to propagate the usage information. That is, if 'x' is used then 'y' and 'z' 20 | are as well. The next iteration will deal with the dependencies of 'y' and 'z'. 21 | 22 | Once there's no more usage information to propagate, we know we've found our fixpoint. 23 | There are several other problems that require fixpoint iteration. Perhaps the most 24 | distinguished is the heap points-to analysis we use to eliminate eval/apply calls. 25 | 26 | -} 27 | 28 | module Fixer.Fixer( 29 | Fixable(..), 30 | Value(), 31 | Rule(), 32 | Fixer(), 33 | addRule, 34 | ioToRule, 35 | conditionalRule, 36 | dynamicRule, 37 | findFixpoint, 38 | calcFixpoint, 39 | isSuperSetOf, 40 | modifiedSuperSetOf, 41 | newFixer, 42 | ioValue, 43 | newValue, 44 | readValue, 45 | readRawValue, 46 | value 47 | ) where 48 | 49 | import Control.Monad.Trans 50 | import Data.IORef 51 | import Data.Monoid 52 | import Data.Typeable 53 | import Data.Unique 54 | import System.IO(hFlush, stdout, Handle, hPutStr) 55 | import Control.Monad 56 | import qualified Data.Set as Set 57 | 58 | -- | Fixable class, must satisfy the following rules 59 | -- 60 | -- isBottom bottom == True 61 | -- x `lub` x == x 62 | -- x `lub` y == y `lub` x 63 | -- x `lub` bottom == x 64 | -- x `minus` bottom == x 65 | -- bottom `minus` x == bottom 66 | -- x `minus` y == z --> y `lub` z == x 67 | 68 | class Fixable a where 69 | bottom :: a 70 | isBottom :: a -> Bool 71 | lub :: a -> a -> a 72 | minus :: a -> a -> a 73 | lte :: a -> a -> Bool 74 | lte x y = isBottom (x `minus` y) 75 | showFixable :: a -> String 76 | showFixable x | isBottom x = "." 77 | | otherwise = "*" 78 | 79 | data MkFixable = forall a . Fixable a => MkFixable (RvValue a) 80 | 81 | data Fixer = Fixer { 82 | vars :: {-# UNPACK #-} !(IORef [MkFixable]), 83 | todo :: {-# UNPACK #-} !(IORef (Set.Set MkFixable)) 84 | } 85 | 86 | newFixer :: MonadIO m => m Fixer 87 | newFixer = liftIO $ do 88 | v <- newIORef [] 89 | t <- newIORef Set.empty 90 | return Fixer { vars = v, todo = t } 91 | 92 | newtype Rule = Rule { unRule :: IO () } 93 | deriving(Typeable) 94 | 95 | instance Monoid Rule where 96 | mempty = Rule (return ()) 97 | mappend (Rule a) (Rule b) = Rule (a >> b) 98 | mconcat rs = Rule $ sequence_ $ map unRule rs 99 | 100 | instance Fixable a => Monoid (Value a) where 101 | mempty = value bottom 102 | mappend a b = UnionValue a b 103 | 104 | data Value a = IOValue (IO (Value a)) | UnionValue (Value a) (Value a) | ConstValue a | IV (RvValue a) 105 | deriving(Typeable) 106 | 107 | instance Fixable a => Show (Value a) where 108 | showsPrec _ (ConstValue a) = showString "<<" . showString (showFixable a) . showString ">>" 109 | showsPrec _ (UnionValue a b) = showString "<<" . shows a . shows b . showString ">>" 110 | showsPrec _ (IOValue _) = showString "<>" 111 | showsPrec _ (IV a) = showString "<<" . shows (hashUnique $ ident a) . showString ">>" 112 | 113 | data RvValue a = RvValue { 114 | ident :: !Unique, 115 | action :: {-# UNPACK #-} !(IORef [a -> IO ()]), 116 | pending :: {-# UNPACK #-} !(IORef a), 117 | current :: {-# UNPACK #-} !(IORef a), 118 | fixer :: Fixer 119 | } 120 | 121 | instance Eq MkFixable where 122 | MkFixable a == MkFixable b = ident a == ident b 123 | MkFixable a /= MkFixable b = ident a /= ident b 124 | instance Ord MkFixable where 125 | MkFixable a `compare` MkFixable b = ident a `compare` ident b 126 | MkFixable a >= MkFixable b = ident a >= ident b 127 | MkFixable a <= MkFixable b = ident a <= ident b 128 | MkFixable a > MkFixable b = ident a > ident b 129 | MkFixable a < MkFixable b = ident a < ident b 130 | 131 | value :: a -> Value a 132 | value x = ConstValue x 133 | 134 | -- | mainly for internal use 135 | ioValue :: IO (Value a) -> Value a 136 | ioValue iov = IOValue iov 137 | 138 | newValue :: (MonadIO m,Fixable a) => Fixer -> a -> m (Value a) 139 | newValue fixer@Fixer { vars = vars } v = liftIO $ do 140 | ident <- newUnique 141 | pending <- newIORef bottom 142 | current <- newIORef bottom 143 | action <- newIORef [] 144 | let value = IV rv 145 | rv = RvValue { ident = ident, fixer = fixer, current = current, pending = pending, action = action } 146 | modifyIORef vars (MkFixable rv:) 147 | propagateValue v rv 148 | return value 149 | 150 | addAction :: Fixable a => Value a -> (a -> IO ()) -> IO () 151 | addAction (ConstValue n) act = act n 152 | addAction (UnionValue a b) act = addAction a act >> addAction b act 153 | addAction (IOValue v) act = v >>= (`addAction` act) 154 | addAction (IV v) act = do 155 | modifyIORef (action v) (act:) 156 | c <- readIORef (current v) 157 | unless (isBottom c) (act c) 158 | 159 | -- | add a rule to the current set 160 | addRule :: MonadIO m => Rule -> m () 161 | addRule (Rule act) = liftIO act 162 | 163 | -- | turn an IO action into a Rule 164 | ioToRule :: IO () -> Rule 165 | ioToRule act = Rule act 166 | 167 | -- | the function must satisfy the rule that if a >= b then f(a) >= f(b) 168 | 169 | modifiedSuperSetOf :: (Fixable a, Fixable b) => Value b -> Value a -> (a -> b) -> Rule 170 | modifiedSuperSetOf (IV rv) (ConstValue cv) r = Rule $ propagateValue (r cv) rv 171 | modifiedSuperSetOf (IV rv) v2 r = Rule $ addAction v2 (\x -> propagateValue (r x) rv) 172 | modifiedSuperSetOf (IOValue iov) v2 r = Rule $ iov >>= \v1 -> unRule $ modifiedSuperSetOf v1 v2 r 173 | modifiedSuperSetOf (ConstValue vb) (ConstValue va) f | f va `lte` vb = Rule $ return () 174 | modifiedSuperSetOf ca@ConstValue {} cb _ = Rule $ fail ("Fixer.modifedSuperSetOf: You cannot modify a constant value:" ++ show(ca,cb)) 175 | modifiedSuperSetOf UnionValue {} _ _ = Rule $ fail "Fixer: You cannot modify a union value" 176 | 177 | isSuperSetOf :: Fixable a => Value a -> Value a -> Rule 178 | (IV rv) `isSuperSetOf` (ConstValue v2) = Rule $ propagateValue v2 rv 179 | (IV rv) `isSuperSetOf` v2 = Rule $ addAction v2 (\x -> propagateValue x rv) 180 | (IOValue iov) `isSuperSetOf` v2 = Rule $ iov >>= unRule . (`isSuperSetOf` v2) 181 | ConstValue v1 `isSuperSetOf` ConstValue v2 | v2 `lte` v1 = Rule $ return () 182 | ConstValue {} `isSuperSetOf` _ = Rule $ fail "Fixer.isSuperSetOf: You cannot modify a constant value" 183 | UnionValue {} `isSuperSetOf` _ = Rule $ fail "Fixer: You cannot modify a union value" 184 | 185 | -- | the function must satisfy the rule that if a >= b then f(a) implies f(b) 186 | conditionalRule :: Fixable a => (a -> Bool) -> Value a -> Rule -> Rule 187 | conditionalRule cond v (Rule act) = Rule $ addAction v (\x -> if cond x then act else return ()) 188 | 189 | dynamicRule :: Fixable a => Value a -> (a -> Rule) -> Rule 190 | dynamicRule v dr = Rule $ addAction v (unRule . dr) 191 | 192 | propagateValue :: Fixable a => a -> RvValue a -> IO () 193 | propagateValue p v = do 194 | if isBottom p then return () else do 195 | (modifyIORef (todo $ fixer v) (Set.insert $ MkFixable v)) 196 | modifyIORef (pending v) (lub p) 197 | 198 | -- | read result, calculating fixpoint if needed 199 | readValue :: (Fixable a,MonadIO m) => Value a -> m a 200 | readValue (IV v) = liftIO $ do 201 | findFixpoint Nothing (fixer v) 202 | readIORef (current v) 203 | readValue (IOValue iov) = liftIO iov >>= readValue 204 | readValue (ConstValue v) = return v 205 | readValue (UnionValue a b) = liftIO $ do 206 | a' <- readValue a 207 | b' <- readValue b 208 | return (lub a' b') 209 | 210 | readRawValue :: (Fixable a,MonadIO m) => Value a -> m a 211 | readRawValue (IV v) = liftIO $ do 212 | readIORef (current v) 213 | readRawValue (IOValue iov) = liftIO iov >>= readRawValue 214 | readRawValue (ConstValue v) = return v 215 | readRawValue (UnionValue a b) = liftIO $ do 216 | a' <- readRawValue a 217 | b' <- readRawValue b 218 | return (lub a' b') 219 | 220 | calcFixpoint :: MonadIO m => String -> Fixer -> m () 221 | calcFixpoint s fixer = findFixpoint (Just (s,stdout)) fixer 222 | 223 | -- | find fixpoint, perhaps printing debugging information to specified handle. will not print anything if no calculation needed. 224 | findFixpoint :: MonadIO m => Maybe (String,Handle) -> Fixer -> m () 225 | findFixpoint msh@(~(Just (mstring,_))) Fixer { vars = vars, todo = todo } = liftIO $ do 226 | to <- readIORef todo 227 | if Set.null to then return () else do 228 | vars <- readIORef vars 229 | let f [] !tl !n | n > 0, tl /= 0 = do 230 | vs <- readIORef todo 231 | writeIORef todo Set.empty 232 | mputStr "(" >> mputStr (show n) >> mputStr ")" >> mFlush 233 | f (Set.toList vs) (tl - 1) 0 234 | f [] _ n | n > 0 = mputStr "[Aborting]\n" >> mFlush >> return () 235 | f [] _ _ = mputStr "\n" >> mFlush >> return () 236 | f (MkFixable v:vs) tl n = do 237 | p <- readIORef (pending v) 238 | c <- readIORef (current v) 239 | let diff = p `minus` c 240 | --if isBottom diff then f vs n else do 241 | if p `lte` c then f vs tl n else do 242 | as <- readIORef (action v) 243 | writeIORef (current v) (p `lub` c) 244 | writeIORef (pending v) bottom 245 | --putStr "[" 246 | --putStr (showFixable diff) 247 | --putStr "]" 248 | mapM_ ($ diff) as 249 | f vs tl (n + 1) 250 | mputStr s = case msh of 251 | Nothing -> return () 252 | Just (_,h) -> hPutStr h s 253 | mFlush = case msh of 254 | Nothing -> return () 255 | Just (_,h) -> hFlush h 256 | mputStr $ "Finding fixpoint for " ++ mstring ++ ": " ++ "[" ++ show (Set.size to) ++ "]" 257 | mFlush 258 | f (Set.toList to) (-1::Int) (0::Int) 259 | 260 | -- some useful instances 261 | 262 | instance Ord n => Fixable (Set.Set n) where 263 | bottom = Set.empty 264 | isBottom = Set.null 265 | lub a b = Set.union a b 266 | minus a b = a Set.\\ b 267 | 268 | instance Fixable Bool where 269 | bottom = False 270 | isBottom x = x == False 271 | lub a b = a || b 272 | minus True False = True 273 | minus False True = False 274 | minus True True = False 275 | minus False False = False 276 | 277 | -- bottom is zero and the lub is the maximum of integer values, as in this is the lattice of maximum, not the additive one. 278 | instance Fixable Int where 279 | bottom = 0 280 | isBottom = (0 ==) 281 | lub a b = max a b 282 | minus a b | a > b = a 283 | minus _ _ = 0 284 | 285 | instance (Fixable a,Fixable b) => Fixable (a,b) where 286 | bottom = (bottom,bottom) 287 | isBottom (a,b) = isBottom a && isBottom b 288 | lub (x,y) (x',y') = (lub x x', lub y y') 289 | minus (x,y) (x',y') = (minus x x', minus y y') 290 | 291 | -- the maybe instance creates a new bottom of nothing. note that (Just bottom) is a distinct point. 292 | instance Fixable a => Fixable (Maybe a) where 293 | bottom = Nothing 294 | isBottom Nothing = True 295 | isBottom _ = False 296 | lub Nothing b = b 297 | lub a Nothing = a 298 | lub (Just a) (Just b) = Just (lub a b) 299 | minus (Just a) (Just b) = Just (minus a b) 300 | minus (Just a) Nothing = Just a 301 | minus Nothing _ = Nothing 302 | -------------------------------------------------------------------------------- /src/Fixer/Supply.hs: -------------------------------------------------------------------------------- 1 | module Fixer.Supply( 2 | Supply(), 3 | newSupply, 4 | supplyReadValues, 5 | sValue, 6 | readSValue, 7 | supplyValue 8 | ) where 9 | 10 | import Control.Monad.Trans 11 | import Data.IORef 12 | import Data.Typeable 13 | import Fixer.Fixer 14 | import qualified Data.Map as Map 15 | 16 | -- maps b's to values of a's, creating them as needed. 17 | 18 | data Supply b a = Supply Fixer {-# UNPACK #-} !(IORef (Map.Map b (Value a))) 19 | deriving(Typeable) 20 | 21 | newSupply :: MonadIO m => Fixer -> m (Supply b a) 22 | newSupply fixer = liftIO $ do 23 | ref <- newIORef Map.empty 24 | return $ Supply fixer ref 25 | 26 | supplyValue :: (MonadIO m, Ord b, Fixable a) => Supply b a -> b -> m (Value a) 27 | supplyValue (Supply fixer ref) b = liftIO $ do 28 | mp <- readIORef ref 29 | case Map.lookup b mp of 30 | Just v -> return v 31 | Nothing -> do 32 | v <- newValue fixer bottom 33 | modifyIORef ref (Map.insert b v) 34 | return v 35 | 36 | sValue :: (Ord b, Fixable a) => Supply b a -> b -> (Value a) 37 | sValue s b = ioValue (supplyValue s b) 38 | 39 | supplyReadValues :: (Fixable a,MonadIO m) => Supply b a -> m [(b,a)] 40 | supplyReadValues (Supply _fixer ref) = liftIO $ do 41 | mp <- readIORef ref 42 | flip mapM (Map.toList mp) $ \ (b,va) -> do 43 | a <- readValue va 44 | return (b,a) 45 | 46 | readSValue :: (MonadIO m, Ord b, Fixable a) => Supply b a -> b -> m a 47 | readSValue s b = do 48 | v <- supplyValue s b 49 | readValue v 50 | -------------------------------------------------------------------------------- /src/FlagOpts.hs: -------------------------------------------------------------------------------- 1 | module FlagOpts(Flag(..),process,helpMsg,helpFlags) where 2 | 3 | import qualified Data.Set as Set 4 | 5 | -- | Flags 6 | data Flag = 7 | BangPatterns -- ^ - bang patterns 8 | | Boehm -- ^ use Boehm garbage collector 9 | | Controlled -- ^ with the '-f' flag, the following options are availible, you can 10 | | Cpp -- ^ pass haskell source through c preprocessor 11 | | Debug -- ^ enable debugging code in generated executable 12 | | Defaulting -- ^ perform defaulting of ambiguous types 13 | | Exists -- ^ exists keyword for existential types recognized 14 | | Ffi -- ^ support foreign function declarations 15 | | Forall -- ^ forall keyword for rank-n types and explicit quantification 16 | | FullInt -- ^ extend Int and Word to 32 bits on a 32 bit machine (rather than 30) 17 | | GlobalOptimize -- ^ perform whole program E optimization 18 | | InlinePragmas -- ^ use inline pragmas 19 | | Jgc -- ^ use the jgc garbage collector 20 | | Lint -- ^ perform lots of extra type checks 21 | | M4 -- ^ pass haskell source through m4 preprocessor 22 | | MonomorphismRestriction -- ^ enforce monomorphism restriction 23 | | Negate -- ^ any particular one by prepending 'no-' to it. 24 | | Prelude -- ^ implicitly import Prelude 25 | | Profile -- ^ enable profiling code in generated executable 26 | | Raw -- ^ just evaluate main to WHNF and nothing else. 27 | | Rules -- ^ use rules 28 | | Standalone -- ^ compile to a standalone executable 29 | | Sugar -- ^ disable all desugarings, only unboxed literals allowed. 30 | | TypeAnalysis -- ^ perform a basic points-to analysis on types right after method generation 31 | | TypeFamilies -- ^ type\/data family support 32 | | UnboxedTuples -- ^ allow unboxed tuple syntax to be recognized 33 | | UnboxedValues -- ^ allow unboxed value syntax 34 | | UserKinds -- ^ user defined kinds 35 | | Wrapper -- ^ wrap main in exception handler 36 | | Never -- ^ Will never be set 37 | deriving(Eq,Ord,Bounded) 38 | 39 | instance Show Flag where 40 | show BangPatterns = "bang-patterns" 41 | show Boehm = "boehm" 42 | show Controlled = "controlled" 43 | show Cpp = "cpp" 44 | show Debug = "debug" 45 | show Defaulting = "defaulting" 46 | show Exists = "exists" 47 | show Ffi = "ffi" 48 | show Forall = "forall" 49 | show FullInt = "full-int" 50 | show GlobalOptimize = "global-optimize" 51 | show InlinePragmas = "inline-pragmas" 52 | show Jgc = "jgc" 53 | show Lint = "lint" 54 | show M4 = "m4" 55 | show MonomorphismRestriction = "monomorphism-restriction" 56 | show Negate = "negate" 57 | show Prelude = "prelude" 58 | show Profile = "profile" 59 | show Raw = "raw" 60 | show Rules = "rules" 61 | show Standalone = "standalone" 62 | show Sugar = "sugar" 63 | show TypeAnalysis = "type-analysis" 64 | show TypeFamilies = "type-families" 65 | show UnboxedTuples = "unboxed-tuples" 66 | show UnboxedValues = "unboxed-values" 67 | show UserKinds = "user-kinds" 68 | show Wrapper = "wrapper" 69 | show Never = "never" 70 | 71 | one "bang-patterns" = Right $ Set.insert BangPatterns 72 | one "no-bang-patterns" = Right $ Set.delete BangPatterns 73 | one "boehm" = Right $ Set.insert Boehm 74 | one "no-boehm" = Right $ Set.delete Boehm 75 | one "controlled" = Right $ Set.insert Controlled 76 | one "no-controlled" = Right $ Set.delete Controlled 77 | one "cpp" = Right $ Set.insert Cpp 78 | one "no-cpp" = Right $ Set.delete Cpp 79 | one "debug" = Right $ Set.insert Debug 80 | one "no-debug" = Right $ Set.delete Debug 81 | one "default" = Right $ foldr (.) id [ f | Right f <- [ one "inline-pragmas",one "rules",one "wrapper",one "defaulting",one "type-analysis",one "monomorphism-restriction",one "global-optimize",one "full-int",one "prelude",one "sugar"]] 82 | one "defaulting" = Right $ Set.insert Defaulting 83 | one "no-defaulting" = Right $ Set.delete Defaulting 84 | one "exists" = Right $ Set.insert Exists 85 | one "no-exists" = Right $ Set.delete Exists 86 | one "ffi" = Right $ Set.insert Ffi 87 | one "no-ffi" = Right $ Set.delete Ffi 88 | one "forall" = Right $ Set.insert Forall 89 | one "no-forall" = Right $ Set.delete Forall 90 | one "full-int" = Right $ Set.insert FullInt 91 | one "no-full-int" = Right $ Set.delete FullInt 92 | one "glasgow-exts" = Right $ foldr (.) id [ f | Right f <- [ one "forall",one "ffi",one "unboxed-tuples"]] 93 | one "global-optimize" = Right $ Set.insert GlobalOptimize 94 | one "no-global-optimize" = Right $ Set.delete GlobalOptimize 95 | one "inline-pragmas" = Right $ Set.insert InlinePragmas 96 | one "no-inline-pragmas" = Right $ Set.delete InlinePragmas 97 | one "jgc" = Right $ Set.insert Jgc 98 | one "no-jgc" = Right $ Set.delete Jgc 99 | one "lint" = Right $ Set.insert Lint 100 | one "no-lint" = Right $ Set.delete Lint 101 | one "m4" = Right $ Set.insert M4 102 | one "no-m4" = Right $ Set.delete M4 103 | one "monomorphism-restriction" = Right $ Set.insert MonomorphismRestriction 104 | one "no-monomorphism-restriction" = Right $ Set.delete MonomorphismRestriction 105 | one "negate" = Right $ Set.insert Negate 106 | one "no-negate" = Right $ Set.delete Negate 107 | one "prelude" = Right $ Set.insert Prelude 108 | one "no-prelude" = Right $ Set.delete Prelude 109 | one "profile" = Right $ Set.insert Profile 110 | one "no-profile" = Right $ Set.delete Profile 111 | one "raw" = Right $ Set.insert Raw 112 | one "no-raw" = Right $ Set.delete Raw 113 | one "rules" = Right $ Set.insert Rules 114 | one "no-rules" = Right $ Set.delete Rules 115 | one "standalone" = Right $ Set.insert Standalone 116 | one "no-standalone" = Right $ Set.delete Standalone 117 | one "sugar" = Right $ Set.insert Sugar 118 | one "no-sugar" = Right $ Set.delete Sugar 119 | one "type-analysis" = Right $ Set.insert TypeAnalysis 120 | one "no-type-analysis" = Right $ Set.delete TypeAnalysis 121 | one "type-families" = Right $ Set.insert TypeFamilies 122 | one "no-type-families" = Right $ Set.delete TypeFamilies 123 | one "unboxed-tuples" = Right $ Set.insert UnboxedTuples 124 | one "no-unboxed-tuples" = Right $ Set.delete UnboxedTuples 125 | one "unboxed-values" = Right $ Set.insert UnboxedValues 126 | one "no-unboxed-values" = Right $ Set.delete UnboxedValues 127 | one "user-kinds" = Right $ Set.insert UserKinds 128 | one "no-user-kinds" = Right $ Set.delete UserKinds 129 | one "wrapper" = Right $ Set.insert Wrapper 130 | one "no-wrapper" = Right $ Set.delete Wrapper 131 | one x = Left x 132 | 133 | {-# NOINLINE process #-} 134 | process s xs = foldr f (s,[]) (map one xs) where 135 | f (Right g) (s,xs) = (g s,xs) 136 | f (Left x) (s,xs) = (s,x:xs) 137 | 138 | {-# NOINLINE helpMsg #-} 139 | helpMsg = "\n-- Code options --\nbang-patterns - bang patterns\ncpp pass haskell source through c preprocessor\nexists exists keyword for existential types recognized\nffi support foreign function declarations\nforall forall keyword for rank-n types and explicit\n quantification\nm4 pass haskell source through m4 preprocessor\nprelude implicitly import Prelude\nsugar disable all desugarings, only unboxed literals allowed.\ntype-families type/data family support\nunboxed-tuples allow unboxed tuple syntax to be recognized\nunboxed-values allow unboxed value syntax\nuser-kinds user defined kinds\n\n-- Typechecking --\ndefaulting perform defaulting of ambiguous types\nmonomorphism-restriction enforce monomorphism restriction\n\n-- Debugging --\nlint perform lots of extra type checks\n\n-- Optimization Options --\nglobal-optimize perform whole program E optimization\ninline-pragmas use inline pragmas\nrules use rules\ntype-analysis perform a basic points-to analysis on types right after\n method generation\n\n-- Code Generation --\nboehm use Boehm garbage collector\ndebug enable debugging code in generated executable\nfull-int extend Int and Word to 32 bits on a 32 bit machine\n (rather than 30)\njgc use the jgc garbage collector\nprofile enable profiling code in generated executable\nraw just evaluate main to WHNF and nothing else.\nstandalone compile to a standalone executable\nwrapper wrap main in exception handler\n\n-- Default settings --\ndefault inline-pragmas rules wrapper defaulting type-analysis\n monomorphism-restriction global-optimize full-int\n prelude sugar\nglasgow-exts forall ffi unboxed-tuples\n" 140 | helpFlags = ["bang-patterns", "boehm", "controlled", "cpp", "debug", "default", "defaulting", "exists", "ffi", "forall", "full-int", "glasgow-exts", "global-optimize", "inline-pragmas", "jgc", "lint", "m4", "monomorphism-restriction", "negate", "prelude", "profile", "raw", "rules", "standalone", "sugar", "type-analysis", "type-families", "unboxed-tuples", "unboxed-values", "user-kinds", "wrapper"] 141 | -------------------------------------------------------------------------------- /src/Grin/Devolve.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving, FlexibleContexts #-} 2 | module Grin.Devolve(twiddleGrin,devolveTransform) where 3 | 4 | import Control.Monad.Identity 5 | import Control.Monad.RWS 6 | import Data.Functor 7 | import Data.IORef 8 | import Data.Maybe 9 | import qualified Data.Map as Map 10 | import qualified Data.Set as Set 11 | 12 | import Grin.Grin 13 | import Grin.Noodle 14 | import Options (verbose,fopts) 15 | import Support.FreeVars 16 | import Support.Transform 17 | import Util.Gen 18 | import Util.SetLike 19 | import qualified FlagOpts as FO 20 | 21 | {-# NOINLINE devolveTransform #-} 22 | devolveTransform = transformParms { 23 | transformDumpProgress = verbose, 24 | transformCategory = "Devolve", 25 | transformPass = "Grin", 26 | transformOperation = devolveGrin 27 | } 28 | 29 | -- devolve grin into a form in which it can be readily converted into C code 30 | -- This lifts any local functions which are ever called in a non-tail-calllike form 31 | -- to the top level. 32 | 33 | devolveGrin :: Grin -> IO Grin 34 | devolveGrin grin = do 35 | col <- newIORef [] 36 | let g (n,l :-> r) = f r >>= \r -> return (n,l :-> r) 37 | f lt@Let { expDefs = defs, expBody = body, .. } = do 38 | let iterZ :: Bool -> Map.Map Tag (Set.Set Val) -> [FuncDef] -> Map.Map Tag (Set.Set Val) 39 | iterZ b pmap (fd@FuncDef { funcDefName = name, funcDefBody = as :-> r }:fs) = iterZ (b || xs' /= xs) (Map.insert name xs pmap) fs where 40 | xs = Set.unions $ xs':catMaybes [ Map.lookup t pmap | t <- Set.toList $ freeVars fd] 41 | xs' = maybe Set.empty id (Map.lookup name pmap) 42 | iterZ True pmap [] = iterZ False pmap defs 43 | iterZ False pmap [] = pmap 44 | 45 | nndefs = [ fd | fd <- defs, funcDefName fd `Set.member` expNonNormal ] 46 | pmap = iterZ False (fromList [ (funcDefName fd, fromList [ Var x y | (x,y) <- Set.toList $ freeVars (funcDefBody fd), x > v0]) | fd <- nndefs ]) nndefs 47 | 48 | (nmaps,rmaps) = splitEither (map z defs) 49 | z fd@FuncDef { funcDefName = name, funcDefBody = as :-> r } 50 | | name `Set.member` expNonNormal = Left ((name,(as ++ xs) :-> pr),xs) 51 | | otherwise = Right fd { funcDefBody = as :-> pr } 52 | where xs = maybe [] Set.toList $ Map.lookup name pmap 53 | pr = runIdentity $ proc r 54 | proc (App a as t) | Just xs <- Map.lookup a pmap = return (App a (as ++ Set.toList xs) t) 55 | proc e = mapExpExp proc e 56 | --mapM_ print (Map.toList pmap) 57 | nmaps <- mapM (g . fst) nmaps 58 | modifyIORef col (++ nmaps) 59 | updateLetProps <$> mapExpExp f lt { expDefs = rmaps, expBody = runIdentity $ proc body } 60 | f e = mapExpExp f e 61 | nf <- mapM g (grinFuncs grin) 62 | lf <- readIORef col 63 | let ntenv = extendTyEnv [ createFuncDef False x y | (x,y) <- lf ] (grinTypeEnv grin) 64 | return $ setGrinFunctions (lf ++ nf) grin { grinPhase = PostDevolve, grinTypeEnv = ntenv } 65 | --if null lf then return ng else devolveGrin ng 66 | --if null lf then return ng else devolveGrin ng 67 | 68 | -- twiddle does some final clean up before translation to C 69 | -- it replaces unused arguments with 'v0' and adds GC notations 70 | 71 | data Env = Env { 72 | envMap :: Map.Map Var Var, 73 | envRoots :: Set.Set Val, 74 | envVar :: Var 75 | } 76 | 77 | newtype R a = R (RWS Env (Set.Set Var) () a) 78 | deriving(Monad,Functor,MonadReader Env,MonadWriter (Set.Set Var), Applicative) 79 | 80 | runR (R x) = fst $ evalRWS x Env { envRoots = mempty, envMap = mempty, envVar = v1 } () 81 | 82 | class Twiddle a where 83 | twiddle :: a -> R a 84 | twiddle a = return a 85 | 86 | instance Twiddle Exp where 87 | twiddle = twiddleExp 88 | 89 | instance Twiddle Val where 90 | twiddle = twiddleVal 91 | 92 | instance Twiddle a => Twiddle [a] where 93 | twiddle xs = mapM twiddle xs 94 | 95 | twiddleExp e = f e where 96 | -- f (BaseOp Promote vs :>>= rest) = f (Return vs :>>= rest) 97 | -- f (BaseOp Demote vs :>>= rest) = f (Return vs :>>= rest) 98 | f (x :>>= lam) | fopts FO.Jgc && isAllocing x = do 99 | roots <- asks envRoots 100 | let nroots = Set.fromList [ Var v t | (v,t) <- Set.toList (freeVars (if isUsing x then ([] :-> x :>>= lam) else lam)), isNode t, v > v0] Set.\\ roots 101 | local (\e -> e { envRoots = envRoots e `Set.union` nroots}) $ do 102 | ne <- return (:>>=) `ap` twiddle x `ap` twiddle lam 103 | return $ gcRoots (Set.toList nroots) ne 104 | f (x :>>= lam) = return (:>>=) `ap` twiddle x `ap` twiddle lam 105 | f l@Let {} = do 106 | ds <- twiddle (expDefs l) 107 | b <- twiddle (expBody l) 108 | return . updateLetProps $ l { expDefs = ds, expBody = b } 109 | f (Case v as) = return Case `ap` twiddle v `ap` twiddle as 110 | f x | fopts FO.Jgc && isUsing x && isAllocing x = do 111 | roots <- asks envRoots 112 | let nroots = Set.fromList [ Var v t | (v,t) <- Set.toList (freeVars x), isNode t, v > v0] Set.\\ roots 113 | local (\e -> e { envRoots = envRoots e `Set.union` nroots}) $ do 114 | ne <- mapExpVal twiddleVal x 115 | return $ gcRoots (Set.toList nroots) ne 116 | f n = do e <- mapExpVal twiddleVal n ; mapExpExp twiddle e 117 | 118 | isUsing (BaseOp StoreNode {} _) = True 119 | isUsing Alloc {} = True 120 | isUsing _ = False 121 | 122 | isAllocing (BaseOp StoreNode {} _) = True 123 | isAllocing (BaseOp Eval {} _) = True 124 | isAllocing (Return [Var {}]) = False 125 | isAllocing (Return [NodeC {}]) = True 126 | isAllocing App {} = True 127 | isAllocing Call {} = True 128 | isAllocing Let {} = True 129 | isAllocing (Case _ as) = any isAllocing [ b | _ :-> b <- as] 130 | isAllocing Alloc {} = True 131 | isAllocing (e :>>= _ :-> y) = isAllocing e || isAllocing y 132 | isAllocing _ = False 133 | 134 | gcRoots [] x = x 135 | gcRoots xs e = GcRoots xs e 136 | 137 | isNode TyNode = True 138 | isNode TyINode = True 139 | isNode (TyPtr TyNode) = True 140 | isNode (TyPtr TyINode) = True 141 | isNode _ = False 142 | 143 | instance Twiddle Lam where 144 | twiddle (vs :-> y) = do 145 | let fvs = freeVars vs :: [Var] 146 | (y,uv) <- censor (Set.filter (`notElem` fvs)) $ listen (twiddle y) 147 | let fvp' = Map.fromList $ concatMap (\v -> if v `Set.member` uv then [] else [(v,v0)]) fvs 148 | vs <- censor (const mempty) . local (\e -> e { envMap = fvp' }) $ twiddle vs 149 | return (vs :-> y) 150 | -- twiddle (vs :-> y) = do 151 | -- cv <- asks envVar 152 | -- let fvp = Map.fromList $ zip fvs [cv ..] 153 | -- fvs = freeVars vs 154 | -- local (\e -> e { envVar = head $ drop (length fvs) [cv .. ], envMap = fvp `Map.union` envMap e }) $ do 155 | -- (y,uv) <- censor (Set.filter (`notElem` take (length fvs) [cv .. ])) $ listen (twiddle y) 156 | -- let fvp' = fmap (\v -> if v `Set.member` uv then v else v0) fvp 157 | -- vs <- censor (const mempty) . local (\e -> e { envMap = fvp' }) $ twiddle vs 158 | -- return (vs :-> y) 159 | 160 | twiddleGrin grin = grinFunctions_s fs' grin where 161 | fs' = runR . twiddle $ grinFunctions grin 162 | 163 | instance Twiddle FuncDef where 164 | twiddle = funcDefBody_uM twiddle 165 | 166 | twiddleVal x = f x where 167 | f var@(Var v ty) = do 168 | em <- asks envMap 169 | case Map.lookup v em of 170 | Just n -> tell (Set.singleton n) >> return (Var n ty) 171 | Nothing -> tell (Set.singleton v) >> return var 172 | f x = mapValVal f x 173 | -------------------------------------------------------------------------------- /src/Grin/EvalInline.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ParallelListComp #-} 2 | module Grin.EvalInline(createEvalApply) where 3 | 4 | import Control.Monad.Identity 5 | import Data.List hiding(union) 6 | import qualified Data.Set as Set 7 | 8 | import GenUtil 9 | import Grin.Grin 10 | import Grin.Noodle 11 | import StringTable.Atom 12 | import Support.CanType(getType) 13 | import Support.FreeVars(freeVars) 14 | import Util.Once 15 | import Util.SetLike 16 | import Util.UniqueMonad() 17 | 18 | {- 19 | data UpdateType = 20 | NoUpdate -- ^ no update is performed 21 | | TrailingUpdate -- ^ an update is placed after the whole evaluation 22 | | HoistedUpdate Val 23 | | SwitchingUpdate [Atom] 24 | 25 | mapExp f (b :-> e) = b :-> f e 26 | 27 | -- create an eval suitable for inlining. 28 | createEval :: UpdateType -> TyEnv -> [Tag] -> Lam 29 | createEval shared te ts' 30 | | null cs = p1 :-> Error "Empty Eval" TyNode 31 | | all tagIsWHNF [ t | t <- ts , tagIsTag t] = p1 :-> Fetch p1 32 | | NoUpdate <- shared, [t] <- ts = p1 :-> Fetch p1 :>>= f t 33 | | TrailingUpdate <- shared, [ot] <- ofts = p1 :-> 34 | Fetch p1 :>>= n2 :-> 35 | Case n2 (mapExp (:>>= n3 :-> Update p1 n3 :>>= unit :-> Return n3) (f ot):map f whnfts) 36 | | TrailingUpdate <- shared = p1 :-> 37 | Fetch p1 :>>= n2 :-> 38 | Case n2 cs :>>= n3 :-> 39 | Update p1 n3 :>>= unit :-> 40 | Return n3 41 | | HoistedUpdate (NodeC t [v]) <- shared = p1 :-> 42 | Fetch p1 :>>= n2 :-> 43 | Case n2 cs :>>= v :-> 44 | Return (NodeC t [v]) 45 | | HoistedUpdate (NodeC t vs) <- shared = p1 :-> 46 | Fetch p1 :>>= n2 :-> 47 | Case n2 cs :>>= Tup vs :-> 48 | Return (NodeC t vs) 49 | | NoUpdate <- shared = p1 :-> 50 | Fetch p1 :>>= n2 :-> 51 | Case n2 cs 52 | | SwitchingUpdate sts <- shared, [ot] <- ofts = p1 :-> 53 | Fetch p1 :>>= n2 :-> 54 | Case n2 (mapExp (:>>= sup p1 sts) (f ot):map f whnfts) 55 | | SwitchingUpdate sts <- shared = let 56 | lf = createEval NoUpdate te ts 57 | -- cu t | tagIsTag t && tagIsWHNF t = return ans where 58 | -- (ts,_) = runIdentity $ findArgsType te t 59 | -- vs = [ Var v ty | v <- [V 4 .. ] | ty <- ts] 60 | -- ans = NodeC t vs :-> Update p1 (NodeC t vs) 61 | -- cu t = error $ "not updatable:" ++ show t 62 | in (p1 :-> (Return p1 :>>= lf) :>>= sup p1 sts) -- n3 :-> Case n3 (concatMap cu sts) :>>= unit :-> Return n3) 63 | where 64 | ts = sortUnder toPackedString ts' 65 | sup p sts = let 66 | cu t | tagIsTag t && tagIsWHNF t = return ans where 67 | (ts,_) = runIdentity $ findArgsType te t 68 | vs = [ Var v ty | v <- [V 4 .. ] | ty <- ts] 69 | ans = NodeC t vs :-> Update p1 (NodeC t vs) 70 | cu t = error $ "not updatable:" ++ show t 71 | in (n3 :-> Case n3 (concatMap cu sts) :>>= unit :-> Return n3) 72 | cs = [f t | t <- ts, tagIsTag t, isGood t ] 73 | isGood t | tagIsWHNF t, HoistedUpdate (NodeC t' _) <- shared, t /= t' = False 74 | isGood _ = True 75 | (whnfts,ofts) = partition tagIsWHNF (filter tagIsTag ts) 76 | g t vs 77 | | tagIsWHNF t, HoistedUpdate (NodeC t' [v]) <- shared = case vs of 78 | [x] -> Return x 79 | _ -> error "createEval: bad thing" 80 | | tagIsWHNF t, HoistedUpdate (NodeC t' vars) <- shared = Return (Tup vs) 81 | | tagIsWHNF t = Return (NodeC t vs) 82 | | 'F':fn <- fromAtom t = ap ('f':fn) vs 83 | | 'B':fn <- fromAtom t = ap ('b':fn) vs 84 | | otherwise = Error ("Bad Tag: " ++ fromAtom t) TyNode 85 | f t = (NodeC t vs :-> g t vs ) where 86 | (ts,_) = runIdentity $ findArgsType te t 87 | vs = [ Var v ty | v <- [V 4 .. ] | ty <- ts] 88 | ap n vs 89 | -- | shared = App (toAtom $ n) vs :>>= n3 :-> Update p1 n3 :>>= unit :-> Return n3 90 | | HoistedUpdate udp@(NodeC t []) <- shared = App fname vs ty :>>= n3 :-> Update p1 udp 91 | | HoistedUpdate udp@(NodeC t [v]) <- shared = App fname vs ty :>>= n3 :-> Return n3 :>>= udp :-> (Update p1 udp :>>= unit :-> Return v) 92 | | HoistedUpdate udp@(NodeC t vars) <- shared = App fname vs ty :>>= n3 :-> (Return n3 :>>= udp :-> (Update p1 udp) :>>= unit :-> Return (Tup vars)) 93 | | otherwise = App fname vs ty 94 | where 95 | fname = toAtom n 96 | Just (_,ty) = findArgsType te fname 97 | -} 98 | createApply :: Ty -> [Ty] -> TyEnv -> [Tag] -> Lam 99 | createApply argType retType te ts' 100 | | null cs && argType == TyUnit = [n1] :-> Error ("Empty Apply:" ++ show ts) retType 101 | | null cs = [n1,a2] :-> Error ("Empty Apply:" ++ show ts) retType 102 | | argType == TyUnit = [n1] :-> Case n1 cs 103 | | otherwise = [n1,a2] :-> Case n1 cs 104 | where 105 | ts = sortBy atomCompare ts' 106 | a2 = Var v2 argType 107 | cs = [ f t | t <- ts, tagGood t] 108 | tagGood t | Just TyTy { tyThunk = TyPApp mt w } <- findTyTy te t = 109 | (Just argType == mt || (argType == TyUnit && Nothing == mt)) && (fmap snd $ findArgsType te w) == Just retType 110 | tagGood _ = False 111 | -- tagGood t | Just (n,fn) <- tagUnfunction t, n > 0 = let 112 | -- ptag = argType == ts !! (length ts - n) 113 | -- rtag = retType == TyNode || (n == 1 && rt == retType) 114 | -- (ts,rt) = runIdentity $ findArgsType te fn 115 | -- in rtag && ptag 116 | f t = ([NodeC t vs] :-> g ) where 117 | (ts,_) = runIdentity $ findArgsType te t 118 | vs = [ Var v ty | v <- [v3 .. ] | ty <- ts] 119 | Just (n,fn) = tagUnfunction t 120 | a2s = if argType == TyUnit then [] else [a2] 121 | g | n == 1 = App fn (vs ++ a2s) ty 122 | | n > 1 = dstore (NodeC (partialTag fn (n - 1)) (vs ++ a2s)) 123 | | otherwise = error "createApply" 124 | where 125 | Just (_,ty) = findArgsType te fn 126 | 127 | dstore x = BaseOp (StoreNode True) [x] 128 | 129 | {-# NOINLINE createEvalApply #-} 130 | createEvalApply :: Grin -> IO Grin 131 | createEvalApply grin = do 132 | let --eval = (funcEval,Tup [earg] :-> ebody) where 133 | -- earg :-> ebody = createEval TrailingUpdate (grinTypeEnv grin) tags 134 | tags = Set.toList $ ftags `Set.union` plads 135 | ftags = freeVars (map (lamExp . snd) $ grinFuncs grin) 136 | plads = Set.fromList $ concatMap mplad (Set.toList ftags) 137 | mplad t | Just (n,tag) <- tagUnfunction t, n > 1 = t:mplad (partialTag tag (n - 1)) 138 | mplad t = [t] 139 | appMap <- newOnceMap 140 | let f (ls :-> exp) = do 141 | exp' <- g exp 142 | return $ ls :-> exp' 143 | g (BaseOp (Apply ty) [fun]) = do 144 | fn' <- runOnceMap appMap (TyUnit,ty) $ do 145 | u <- newUniq 146 | return (toAtom $ "bapply_" ++ show u) 147 | return (App fn' [fun] ty) 148 | g (BaseOp (Apply ty) [fun,arg]) = do 149 | fn' <- runOnceMap appMap (getType arg,ty) $ do 150 | u <- newUniq 151 | return (toAtom $ "bapply_" ++ show u) 152 | return (App fn' [fun,arg] ty) 153 | g x = mapExpExp g x 154 | funcs <- mapMsnd f (grinFuncs grin) 155 | as <- onceMapToList appMap 156 | let (apps,ntyenv) = unzip $ map cf as 157 | cf ((targ,tret),name) | targ == TyUnit = ((name,appBody),(name,tyTy { tySlots = [TyNode],tyReturn = tret })) where 158 | appBody = createApply targ tret (grinTypeEnv grin) tags 159 | cf ((targ,tret),name) = ((name,appBody),(name,tyTy { tySlots = [TyNode,targ],tyReturn = tret })) where 160 | appBody = createApply targ tret (grinTypeEnv grin) tags 161 | TyEnv tyEnv = grinTypeEnv grin 162 | appTyEnv = fromList ntyenv 163 | return $ setGrinFunctions (apps ++ funcs) grin { grinTypeEnv = TyEnv (tyEnv `union` appTyEnv) } 164 | -------------------------------------------------------------------------------- /src/Grin/Grin.hs-boot: -------------------------------------------------------------------------------- 1 | module Grin.Grin where 2 | 3 | 4 | data Exp 5 | data Grin 6 | data Val 7 | data Lam 8 | -------------------------------------------------------------------------------- /src/Grin/HashConst.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Grin.HashConst(newConst,HcHash(),HcNode(..),toList,emptyHcHash) where 3 | 4 | import Control.Monad.State 5 | import qualified Data.Map as Map 6 | import qualified Data.Set as Set 7 | 8 | import Grin.Grin 9 | import StringTable.Atom 10 | import Util.Graph 11 | 12 | -- TODO tuples 13 | 14 | data HcNode = HcNode {-# UNPACK #-} !Atom [Either Val Int] 15 | deriving(Show,Ord,Eq) 16 | 17 | data HcHash = HcHash !Int (Map.Map HcNode Int) 18 | deriving(Show) 19 | 20 | emptyHcHash = HcHash 1 Map.empty 21 | 22 | newConst :: MonadState HcHash m => Set.Set Atom -> Val -> m (Bool,Int) 23 | newConst cpr n = f n where 24 | f (NodeC t vs) = do 25 | let g (Lit i ty) 26 | | otherwise = return $ Left (Lit i ty) 27 | g vp@(ValPrim _ _ ty) 28 | | otherwise = return $ Left vp 29 | g x@(Var (V n) _) | n < 0 = return $ Left x 30 | g n@(Const (NodeC _ [])) = return $ Left n 31 | g n@(NodeC _ []) = return $ Left n 32 | g n@(Const (NodeC a _)) | a `Set.member` cpr = return $ Left n 33 | g n@(NodeC a _) | a `Set.member` cpr = return $ Left n 34 | g (Const n) = liftM (Right . snd) $ f n 35 | g n@NodeC {} = liftM (Right . snd) $ f n 36 | g e = error $ "HashConst.g: " ++ show e 37 | vs' <- mapM g vs 38 | let n = HcNode t vs' 39 | HcHash c h <- get 40 | case Map.lookup n h of 41 | Just n -> return (True,n) 42 | Nothing -> do 43 | let h' = Map.insert n c h 44 | put $ HcHash (c + 1) h' 45 | return (False,c) 46 | f _ = error "HashConst.newConst'" 47 | 48 | toList :: HcHash -> [(HcNode,Int)] 49 | toList (HcHash _ mp) = reverse ans where 50 | gr = newGraph (Map.toList mp) snd (gk . fst) 51 | gk (HcNode _ xs) = [ i | Right i <- xs] 52 | ans = topSort gr 53 | -------------------------------------------------------------------------------- /src/Grin/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | module Grin.Main(compileToGrin,compileGrinToC) where 3 | 4 | import Control.Monad 5 | import Data.List 6 | import Data.Monoid(mappend) 7 | import System.Directory 8 | import qualified Data.ByteString as BS 9 | import qualified Data.ByteString.Lazy as LBS 10 | import qualified Data.ByteString.Lazy.UTF8 as LBS 11 | import qualified Data.Map as Map 12 | import qualified Data.Set as Set 13 | import qualified System.FilePath as FP 14 | import qualified System.Exit as System 15 | import qualified System.Process as System 16 | 17 | import C.Prims 18 | import Grin.DeadCode 19 | import Grin.Devolve(twiddleGrin,devolveTransform) 20 | import Grin.EvalInline(createEvalApply) 21 | --import Grin.FromE 22 | import Grin.Grin 23 | import Grin.Lint 24 | import Grin.NodeAnalyze 25 | import Grin.Optimize 26 | import Grin.SSimplify 27 | import Grin.Show 28 | import Grin.StorageAnalysis 29 | --import Ho.ReadSource 30 | import Options 31 | import PackedString 32 | import RawFiles 33 | import Support.TempDir 34 | import Support.Transform 35 | import Util.Gen 36 | import qualified C.FromGrin2 as FG2 37 | import qualified FlagDump as FD 38 | import qualified Stats 39 | 40 | import qualified FlagOpts as FO 41 | 42 | 43 | fetchCompilerFlags :: IO (FilePath, -- ^ file path to compiler 44 | [String]) -- ^ compiler arguments 45 | fetchCompilerFlags = return (cc,args) where 46 | lup k = maybe "" id $ Map.lookup k (optInis options) 47 | boehmOpts | fopts FO.Boehm = ["-D_JHC_GC=_JHC_GC_BOEHM", "-lgc"] 48 | | fopts FO.Jgc = ["-D_JHC_GC=_JHC_GC_JGC"] 49 | | otherwise = [] 50 | profileOpts | fopts FO.Profile || lup "profile" == "true" = ["-D_JHC_PROFILE=1"] 51 | | otherwise = [] 52 | debug = if fopts FO.Debug then words (lup "cflags_debug") else words (lup "cflags_nodebug") 53 | cc = lup "cc" 54 | args = words (lup "cflags") ++ debug ++ optCCargs options ++ boehmOpts ++ profileOpts 55 | 56 | {-# NOINLINE compileToGrin #-} 57 | compileToGrin x = do 58 | stats <- Stats.new 59 | when verbose $ Stats.print "Grin" Stats.theStats 60 | wdump FD.GrinInitial $ do dumpGrin "initial" x 61 | x <- transformGrin simplifyParms x 62 | wdump FD.GrinNormalized $ do dumpGrin "normalized" x 63 | x <- explicitRecurse x 64 | lintCheckGrin x 65 | x <- transformGrin deadCodeParms x 66 | x <- transformGrin simplifyParms x 67 | x <- transformGrin pushParms x 68 | x <- transformGrin simplifyParms x 69 | putProgressLn "-- Speculative Execution Optimization" 70 | x <- grinSpeculate x 71 | lintCheckGrin x 72 | x <- transformGrin deadCodeParms x 73 | x <- transformGrin simplifyParms x 74 | x <- transformGrin pushParms x 75 | x <- transformGrin simplifyParms x 76 | wdump FD.OptimizationStats $ Stats.print "Optimization" stats 77 | putProgressLn "-- Node Usage Analysis" 78 | wdump FD.GrinPreeval $ dumpGrin "preeval" x 79 | x <- transformGrin nodeAnalyzeParms x 80 | x <- transformGrin simplifyParms x 81 | wdump FD.GrinPreeval $ dumpGrin "preeval2" x 82 | x <- transformGrin nodeAnalyzeParms x 83 | x <- transformGrin simplifyParms x 84 | x <- createEvalApply x 85 | x <- transformGrin simplifyParms x 86 | putProgressLn "-- Grin Devolution" 87 | wdump FD.GrinFinal $ dumpGrin "predevolve" x 88 | x <- transformGrin devolveTransform x 89 | --x <- opt "After Devolve Optimization" x 90 | x <- transformGrin simplifyParms x 91 | x <- return $ twiddleGrin x 92 | -- x <- return $ normalizeGrin x 93 | -- x <- return $ twiddleGrin x 94 | x <- storeAnalyze x 95 | dumpFinalGrin x 96 | return x 97 | 98 | dumpFinalGrin grin = do 99 | wdump FD.GrinGraph $ do 100 | let dot = graphGrin grin 101 | writeFile (outputName ++ "_grin.dot") dot 102 | wdump FD.GrinFinal $ dumpGrin "final" grin 103 | 104 | compileGrinToC grin = do 105 | let (cg,Requires reqs) = FG2.compileGrin grin 106 | rls = filter ("-l" `isPrefixOf`) $ map (unpackPS . snd) (Set.toList reqs) 107 | fn = outputName ++ lup "executable_extension" 108 | lup k = maybe "" id $ Map.lookup k (optInis options) 109 | cf <- case (optOutName options,optStop options) of 110 | (Just fn,StopC) -> return fn 111 | _ | dump FD.C -> return (fn ++ "_code.c") 112 | | otherwise -> fileInTempDir ("main_code.c") (\_ -> return ()) 113 | (argstring,sversion) <- getArgString 114 | (cc,args) <- fetchCompilerFlags 115 | forM_ [("HsFFI.h",hsffi_h), 116 | ("jhc_rts_header.h",jhc_rts_header_h), 117 | ("lib/lib_cbits.c",lib_cbits_c), 118 | ("lib/lib_cbits.h",lib_cbits_h), 119 | ("rts/cdefs.h",cdefs_h), 120 | ("rts/constants.h",constants_h), 121 | ("rts/gc.h",gc_h), 122 | ("rts/gc_jgc.c",gc_jgc_c), 123 | ("rts/gc_jgc.h",gc_jgc_h), 124 | ("rts/gc_jgc_internal.h",gc_jgc_internal_h), 125 | ("rts/gc_none.c",gc_none_c), 126 | ("rts/gc_none.h",gc_none_h), 127 | ("rts/jhc_rts.c",jhc_rts_c), 128 | ("rts/jhc_rts.h",jhc_rts_h), 129 | ("rts/profile.c",profile_c), 130 | ("rts/profile.h",profile_h), 131 | ("rts/rts_support.c",rts_support_c), 132 | ("rts/rts_support.h",rts_support_h), 133 | -- ("rts/slub.c",slub_c), 134 | ("rts/stableptr.c",stableptr_c), 135 | ("sys/bitarray.h",bitarray_h), 136 | ("sys/queue.h",queue_h), 137 | ("sys/wsize.h",wsize_h)] $ \ (fn,bs) -> do 138 | fileInTempDir fn $ flip BS.writeFile bs 139 | let cFiles = ["rts/profile.c", "rts/rts_support.c", "rts/gc_none.c", 140 | "rts/jhc_rts.c", "lib/lib_cbits.c", "rts/gc_jgc.c", 141 | "rts/stableptr.c"] 142 | tdir <- getTempDir 143 | ds <- iocatch (getDirectoryContents (tdir FP. "cbits")) (\_ -> return []) 144 | let extraCFiles = map (tdir FP.) cFiles ++ ["-I" ++ tdir ++ "/cbits", "-I" ++ tdir ] ++ [ tdir FP. "cbits" FP. fn | fn@(reverse -> 'c':'.':_) <- ds ] 145 | let comm = shellQuote $ [cc] ++ extraCFiles ++ [cf, "-o", fn] ++ args ++ rls 146 | globalvar n c = LBS.fromString $ "char " ++ n ++ "[] = \"" ++ c ++ "\";" 147 | putProgressLn ("Writing " ++ show cf) 148 | LBS.writeFile cf $ LBS.intercalate (LBS.fromString "\n") [ 149 | globalvar "jhc_c_compile" comm, globalvar "jhc_command" argstring, 150 | globalvar "jhc_version" sversion,LBS.empty,cg] 151 | when (optStop options == StopC) $ 152 | exitSuccess 153 | putProgressLn ("Running: " ++ comm) 154 | r <- System.system comm 155 | when (r /= System.ExitSuccess) $ fail "C code did not compile." 156 | return () 157 | 158 | grinParms = transformParms { 159 | transformDumpProgress = verbose, 160 | transformPass = "Grin" 161 | } 162 | 163 | simplifyParms = grinParms { 164 | transformCategory = "Simplify", 165 | transformOperation = Grin.SSimplify.simplify, 166 | transformIterate = IterateDone 167 | } 168 | 169 | nodeAnalyzeParms = grinParms { 170 | transformCategory = "NodeAnalyze", 171 | transformOperation = nodealyze 172 | } where 173 | nodealyze grin = do 174 | stats <- Stats.new 175 | g <- deadCode stats (grinEntryPointNames grin) grin 176 | g <- nodeAnalyze g 177 | st <- Stats.readStat stats 178 | return g { grinStats = grinStats grin `mappend` st } 179 | 180 | pushParms = grinParms { 181 | transformCategory = "Push", 182 | transformOperation = pushGrin 183 | } where 184 | pushGrin grin = do 185 | nf <- mapMsnd (grinPush undefined) (grinFuncs grin) 186 | return $ setGrinFunctions nf grin 187 | 188 | deadCodeParms = grinParms { 189 | transformCategory = "DeadCode", 190 | transformOperation = op 191 | } where 192 | op grin = do 193 | stats <- Stats.new 194 | g <- deadCode stats (grinEntryPointNames grin) grin 195 | st <- Stats.readStat stats 196 | return g { grinStats = grinStats grin `mappend` st } 197 | -------------------------------------------------------------------------------- /src/Grin/Noodle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeFamilies, RankNTypes #-} 2 | module Grin.Noodle where 3 | 4 | -- various routines for manipulating and exploring grin code. 5 | 6 | import Control.Monad.Writer 7 | import qualified Data.Set as Set 8 | 9 | import C.Prims 10 | import Debug.Trace 11 | import Grin.Grin 12 | import Options(flint) 13 | import StringTable.Atom(Atom()) 14 | import Support.CanType 15 | import Support.FreeVars 16 | import Support.Tickle 17 | import Util.GMap 18 | import Util.Gen 19 | import Util.HasSize 20 | import Util.SetLike 21 | 22 | modifyTail :: Lam -> Exp -> Exp 23 | modifyTail lam@(_ :-> lb) te = f (sempty :: GSet Atom) te where 24 | lamFV = freeVars lam :: GSet Var 25 | f lf e | False && trace ("modifyTail: " ++ show (lf,e)) False = undefined 26 | f _ (Error s ty) = Error s (getType lb) 27 | f lf (Case x ls) = Case x (map (g lf) ls) 28 | f _ lt@Let {expIsNormal = False } = lt :>>= lam 29 | f lf lt@Let {expDefs = defs, expBody = body, expIsNormal = True } = updateLetProps lt { expBody = f nlf body, expDefs = defs' } where 30 | nlf = lf `union` fromList (map funcDefName defs) 31 | defs' = [ updateFuncDefProps d { funcDefBody = g nlf (funcDefBody d) } | d <- defs ] 32 | f lf lt@MkCont {expLam = lam, expCont = cont } = lt { expLam = g lf lam, expCont = g lf cont } 33 | f lf (e1 :>>= p :-> e2) = e1 :>>= p :-> f lf e2 34 | f lf e@(App a as t) | a `member` lf = App a as (getType lb) 35 | f lf e = e :>>= lam 36 | g lf (p :-> e) | flint && not (isEmpty $ intersection (freeVars p) lamFV) = error "modifyTail: lam floated inside bad scope" 37 | g lf (p :-> e) = p :-> f lf e 38 | 39 | instance Tickleable Exp Lam where 40 | tickleM = mapBodyM 41 | instance Tickleable Exp Exp where 42 | tickleM = mapExpExp 43 | instance Tickleable Val Exp where 44 | tickleM = mapExpVal 45 | instance Tickleable Val Val where 46 | tickleM = mapValVal 47 | tickleM_ = mapValVal_ 48 | instance Tickleable Lam Grin where 49 | tickleM f grin = liftM (`setGrinFunctions` grin) $ mapM (\x -> do nb <- f (funcDefBody x); return (funcDefName x, nb)) (grinFunctions grin) 50 | instance Tickleable Lam FuncDef where 51 | tickleM f fd = funcDefBody_uM f fd 52 | instance Tickleable (Atom,Lam) FuncDef where 53 | tickleM f fd@FuncDef { funcDefName = n, funcDefBody = b } = do 54 | (n',b') <- f (n,b) 55 | return $ updateFuncDefProps fd { funcDefBody = b', funcDefName = n' } 56 | 57 | mapBodyM :: Monad m => (Exp -> m Exp) -> Lam -> m Lam 58 | mapBodyM f (x :-> y) = f y >>= return . (x :->) 59 | 60 | mapExpVal :: Monad m => (Val -> m Val) -> Exp -> m Exp 61 | mapExpVal g x = f x where 62 | f (App a vs t) = return (App a) `ap` mapM g vs `ap` return t 63 | f (BaseOp a vs) = return (BaseOp a) `ap` mapM g vs 64 | f (Return vs) = return Return `ap` mapM g vs 65 | f (Prim x vs t) = return (Prim x) `ap` mapM g vs `ap` return t 66 | f e@Alloc { expValue = v, expCount = c } = do 67 | v <- g v 68 | c <- g c 69 | return e { expValue = v, expCount = c } 70 | f (Case v as) = do 71 | v <- g v 72 | return (Case v as) 73 | f e = return e 74 | 75 | mapValVal fn x = f x where 76 | f (NodeC t vs) = return (NodeC t) `ap` mapM fn vs 77 | f (Index a b) = return Index `ap` fn a `ap` fn b 78 | f (Const v) = return Const `ap` fn v 79 | f (ValPrim p vs ty) = return (ValPrim p) `ap` mapM fn vs `ap` return ty 80 | f x = return x 81 | 82 | mapValVal_ fn x = f x where 83 | f (NodeC t vs) = mapM_ fn vs 84 | f (Index a b) = fn a >> fn b >> return () 85 | f (Const v) = fn v >> return () 86 | f (ValPrim p vs ty) = mapM_ fn vs >> return () 87 | f _ = return () 88 | 89 | mapExpLam fn e = f e where 90 | f (a :>>= b) = return (a :>>=) `ap` fn b 91 | f (Case e as) = return (Case e) `ap` mapM fn as 92 | f lt@Let { expDefs = defs } = do 93 | defs' <- forM defs $ \d -> do 94 | b <- fn $ funcDefBody d 95 | return $ updateFuncDefProps d { funcDefBody = b } 96 | return $ updateLetProps lt { expDefs = defs' } 97 | f nr@NewRegion { expLam = lam } = do 98 | lam <- fn lam 99 | return $ nr { expLam = lam } 100 | f e@MkCont { expCont = c, expLam = l } = do 101 | c <- fn c 102 | l <- fn l 103 | return $ e { expCont = c, expLam = l } 104 | f e = return e 105 | 106 | mapExpExp fn e = f e where 107 | f (a :>>= b) = return (:>>=) `ap` fn a `ap` g b 108 | f l@Let { expBody = b, expDefs = defs } = do 109 | b <- fn b 110 | return updateLetProps `ap` (mapExpLam g l { expBody = b }) 111 | f (GcRoots vs e) = return (GcRoots vs) `ap` fn e 112 | f e = mapExpLam g e 113 | g (l :-> e) = return (l :->) `ap` fn e 114 | 115 | mapFBodies f xs = mapM f' xs where 116 | f' fd@FuncDef { funcDefBody = l :-> r } = do 117 | r' <- f r 118 | return $ updateFuncDefProps fd { funcDefBody = l :-> r' } 119 | 120 | funcDefBody_uM f fd@FuncDef { funcDefBody = b } = do 121 | b' <- f b 122 | return $ updateFuncDefProps fd { funcDefBody = b' } 123 | 124 | grinFunctions_s nf grin = grin { grinFunctions = nf } 125 | 126 | -------------------------- 127 | -- examining and reporting 128 | -------------------------- 129 | 130 | isManifestNode :: Monad m => Exp -> m [Atom] 131 | isManifestNode e = f (sempty :: GSet Atom) e where 132 | f lf _ | False && trace ("isManifestNode: " ++ show lf) False = undefined 133 | f lf (Return [(NodeC t _)]) = return [t] 134 | f lf Error {} = return [] 135 | f lf (App a _ _) | a `member` lf = return [] 136 | f lf Let { expBody = body, expIsNormal = False } = f lf body 137 | f lf Let { expBody = body, expDefs = defs, expIsNormal = True } = ans where 138 | nlf = lf `union` fromList (map funcDefName defs) 139 | ans = do 140 | xs <- mapM (f nlf . lamExp . funcDefBody) defs 141 | b <- f nlf body 142 | return (concat (b:xs)) 143 | f lf (Case _ ls) = do 144 | cs <- Prelude.mapM (f lf) [ e | _ :-> e <- ls ] 145 | return $ concat cs 146 | f lf (_ :>>= _ :-> e) = isManifestNode e 147 | f lf _ = fail "not manifest node" 148 | 149 | -- | Is a Val constant? 150 | valIsConstant :: Val -> Bool 151 | valIsConstant (NodeC _ xs) = all valIsConstant xs 152 | valIsConstant Lit {} = True 153 | valIsConstant Const {} = True 154 | valIsConstant (Var v _) | v < v0 = True 155 | valIsConstant (Index v t) = valIsConstant v && valIsConstant t 156 | valIsConstant ValPrim {} = True 157 | valIsConstant _ = False 158 | 159 | -- NOPs will not produce any code at run-time so we can tail-call through them. 160 | isNop (BaseOp Promote _) = True 161 | isNop (BaseOp Demote _) = True 162 | isNop _ = False 163 | 164 | isOmittable (BaseOp Promote _) = True 165 | isOmittable (BaseOp Demote _) = True 166 | isOmittable (BaseOp PeekVal _) = True 167 | isOmittable (BaseOp ReadRegister _) = True 168 | isOmittable (BaseOp NewRegister _) = True 169 | isOmittable (BaseOp GcPush _) = True -- omittable because if we don't use the returned gc context, then we don't need to push to begin with 170 | isOmittable (BaseOp (StoreNode _) _) = True 171 | isOmittable Alloc {} = True 172 | isOmittable (Return {}) = True 173 | isOmittable Prim { expPrimitive = aprim } = primIsCheap aprim 174 | isOmittable (Case x ds) = all isOmittable [ e | _ :-> e <- ds ] 175 | isOmittable Let { expBody = x } = isOmittable x 176 | isOmittable (e1 :>>= _ :-> e2) = isOmittable e1 && isOmittable e2 177 | isOmittable _ = False 178 | 179 | isErrOmittable (BaseOp Overwrite _) = True 180 | isErrOmittable (BaseOp PokeVal _) = True 181 | isErrOmittable (BaseOp WriteRegister _) = True 182 | isErrOmittable (e1 :>>= _ :-> e2) = isErrOmittable e1 && isErrOmittable e2 183 | isErrOmittable (Case x ds) = all isErrOmittable [ e | _ :-> e <- ds ] 184 | isErrOmittable x = isOmittable x 185 | 186 | -- collect tail and normally called functions 187 | -- expression (tail called, non tail called) 188 | collectFuncs :: Exp -> (Set.Set Atom,Set.Set Atom) 189 | collectFuncs exp = runWriter (cfunc exp) where 190 | clfunc (l :-> r) = cfunc r 191 | cfunc e | False && trace ("isManifestNode: " ++ show e) False = undefined 192 | cfunc (e :>>= v :-> op@(BaseOp _ v')) | isNop op && v == v' = do cfunc e 193 | cfunc (e :>>= y) = do 194 | xs <- cfunc e 195 | tell xs 196 | clfunc y 197 | cfunc (App a _ _) = return (singleton a) 198 | cfunc (Case _ as) = do 199 | rs <- mapM clfunc as 200 | return (mconcat rs) 201 | cfunc Let { expFuncCalls = (tail,nonTail) } = do 202 | tell nonTail 203 | return tail 204 | cfunc Error {} = return mempty 205 | cfunc Prim {} = return mempty 206 | cfunc Return {} = return mempty 207 | cfunc BaseOp {} = return mempty 208 | cfunc Alloc {} = return mempty 209 | cfunc GcRoots { expBody = b} = cfunc b 210 | cfunc NewRegion { expLam = l } = clfunc l 211 | cfunc MkCont { expCont = l1, expLam = l2 } = do 212 | a <- clfunc l1 213 | b <- clfunc l2 214 | return (a `mappend` b) 215 | cfunc x = error "Grin.Noodle.collectFuncs: unknown" 216 | 217 | grinLet defs body = updateLetProps Let { 218 | expDefs = defs, 219 | expBody = body, 220 | expInfo = mempty, 221 | expNonNormal = undefined, 222 | expIsNormal = undefined, 223 | expFuncCalls = undefined } 224 | 225 | updateLetProps Let { expDefs = [], expBody = body } = body 226 | updateLetProps lt@Let { expBody = body, expDefs = defs } = 227 | lt { 228 | expFuncCalls = (tail \\ myDefs, nonTail \\ myDefs), 229 | expNonNormal = notNormal, 230 | expIsNormal = isEmpty notNormal 231 | } where 232 | (tail,nonTail) = mconcatMap collectFuncs (body : map (lamExp . funcDefBody) defs) 233 | notNormal = nonTail `intersection` (fromList $ map funcDefName defs) 234 | myDefs = fromList $ map funcDefName defs 235 | updateLetProps e = e 236 | 237 | data ReturnInfo = ReturnNode (Maybe Atom,[Ty]) | ReturnConst Val | ReturnCalls Atom | ReturnOther | ReturnError 238 | deriving(Eq,Ord) 239 | 240 | getReturnInfo :: Exp -> [ReturnInfo] 241 | getReturnInfo e = ans where 242 | ans = execWriter (f (sempty :: GSet Atom) e) 243 | tells x = tell [x] 244 | f lf (Return [(NodeC t as)]) = tells (ReturnNode (Just t,map getType as)) 245 | f lf (Return [z]) | valIsConstant z = tell [ReturnConst z] 246 | f lf Error {} = tells ReturnError 247 | f lf (Case _ ls) = do Prelude.mapM_ (f lf) [ e | _ :-> e <- ls ] 248 | f lf (_ :>>= _ :-> e) = f lf e 249 | f lf Let { expBody = body, expIsNormal = False } = f lf body 250 | f lf (App a _ _) | a `member` lf = return () 251 | f lf Let { expBody = body, expDefs = defs, expIsNormal = True } = ans where 252 | nlf = lf `union` fromList (map funcDefName defs) 253 | ans = do 254 | mapM_ (f nlf . lamExp . funcDefBody) defs 255 | f nlf body 256 | f _ (App a _ _) = tells $ ReturnCalls a 257 | f _ e = tells ReturnOther 258 | 259 | mapGrinFuncsM :: Monad m => (Atom -> Lam -> m Lam) -> Grin -> m Grin 260 | mapGrinFuncsM f grin = liftM (`setGrinFunctions` grin) $ mapM (\x -> do nb <- f (funcDefName x) (funcDefBody x); return (funcDefName x, nb)) (grinFunctions grin) 261 | -------------------------------------------------------------------------------- /src/Grin/Optimize.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} 2 | module Grin.Optimize(grinPush,grinSpeculate) where 3 | 4 | import Control.Monad.State 5 | import Data.List 6 | import qualified Data.Set as Set 7 | 8 | import C.Prims 9 | import Grin.Grin 10 | import Grin.Noodle 11 | import Options (verbose) 12 | import Stats hiding(null,isEmpty) 13 | import StringTable.Atom 14 | import Support.CanType 15 | import Support.FreeVars 16 | import Util.GMap 17 | import Util.Graph 18 | import Util.HasSize 19 | import Util.SetLike 20 | 21 | data PExp = PExp { 22 | pexpUniq :: Int, 23 | pexpBind :: [Val], 24 | pexpExp :: Exp, 25 | pexpProvides :: [Var], 26 | pexpDeps :: [Int] 27 | } deriving(Show) 28 | 29 | instance Eq PExp where 30 | a == b = pexpUniq a == pexpUniq b 31 | 32 | makeDeps :: [PExp] -> PExp -> PExp 33 | makeDeps cs pexp = pexp { pexpProvides = freeVars (pexpBind pexp), pexpDeps = deps } where 34 | deps = [ pexpUniq c | c <- cs, not $ null $ fvs `intersect` pexpProvides c ] 35 | fvs = freeVars (pexpExp pexp) 36 | 37 | justDeps :: [PExp] -> [Var] -> [Int] 38 | justDeps cs fs = deps where 39 | deps = [ pexpUniq c | c <- cs, not $ null $ fs `intersect` pexpProvides c ] 40 | 41 | -- | grinPush pushes the definitions of variables as far inward as they can go so 42 | -- peephole optimizations have a better chance of firing. when the order of definitons 43 | -- doesn't matter, it uses heuristics to decide which one to push to allow the most 44 | -- peephole optimizations. 45 | 46 | grinPush :: Stats -> Lam -> IO Lam 47 | grinPush stats (l :-> e) = ans where 48 | ans = do 49 | -- putStrLn "@@@ grinPush" 50 | e' <- evalStateT (f e) (1,[]) 51 | return (l :-> e') 52 | f (exp :>>= v :-> e2) | isOmittable exp = do 53 | (nn,cv) <- get 54 | let npexp = makeDeps cv PExp { pexpUniq = nn, pexpBind = v, pexpExp = exp, pexpDeps = undefined, pexpProvides = undefined } 55 | put (nn+1,npexp:cv) 56 | f e2 57 | f (exp :>>= v :-> e2) = do 58 | exp <- fixupLet exp 59 | (v',exp') <- dropAny (Just v) exp 60 | e2' <- f e2 61 | return $ exp' :>>= v' :-> e2' 62 | f exp = do 63 | exp <- fixupLet exp 64 | (_,exp') <- dropAny Nothing exp 65 | return exp' 66 | 67 | fixupLet lt@Let { expDefs = defs, expBody = b } = do 68 | let def = (fromList $ map funcDefName defs :: GSet Atom) 69 | f (e :>>= l :-> r) | isEmpty (freeVars e `intersection` def) = do 70 | exp <- f r 71 | return (e :>>= l :-> exp) 72 | f r = return $ updateLetProps lt { expBody = r } 73 | f b 74 | fixupLet exp = return exp 75 | dropAny mv (exp::Exp) = do 76 | (nn,xs) <- get 77 | let (reachable',_graph) = newGraphReachable xs pexpUniq pexpDeps 78 | deps = justDeps xs (freeVars exp) 79 | reached = reachable' deps 80 | --dropped = case prefered reached exp of 81 | -- Just (x:_) | [] <- [ r | r <- reached, pexpUniq x `elem` pexpDeps r ] -> (reverse $ topSort $ newGraph (filter (/= x) reached) pexpUniq pexpDeps) ++ [x] 82 | -- _ -> reverse $ topSort $ newGraph reached pexpUniq pexpDeps 83 | dropped = reverse $ topSort $ newGraph reached pexpUniq pexpDeps 84 | ff pexp exp = pexpExp pexp :>>= pexpBind pexp :-> exp 85 | ebinds = [ Var v t | (v,t) <- Set.toList $ freeVars (map pexpBind dropped) ] 86 | (exp',mv') | Just vv <- mv = let mv' = vv ++ ebinds in (exp :>>= vv :-> Return mv',mv') 87 | | otherwise = (exp,[]) 88 | put (nn,[ x | x <- xs, pexpUniq x `notElem` (map pexpUniq reached) ]) 89 | -- when (not $ null dropped) $ lift $ do 90 | -- putStrLn "@@@ dropped" 91 | -- mapM_ Prelude.print dropped 92 | return (mv',foldr ff exp' dropped :: Exp) 93 | -- | preferentially pull definitons of the variable this returns right next to it as it admits a peephole optimization 94 | -- prefer (Store v@Var {}) = return v 95 | -- prefer (App fn [v@Var {}] _) | fn == funcEval = return v 96 | -- prefer (App fn [v@Var {},_] _)| fn == funcApply = return v 97 | -- prefer (App fn [v@Var {}] _) | fn == funcApply = return v 98 | -- prefer (Update _ v@Var {}) = return v 99 | -- prefer (Update v@Var {} _) = return v 100 | -- prefer _ = fail "no preference" 101 | -- _prefered pexps exp = do 102 | -- v <- prefer exp 103 | -- return [ p | p <- pexps, v == pexpBind p] 104 | 105 | --grinPush :: Stats -> Lam -> IO Lam 106 | --grinPush stats lam = ans where 107 | -- ans = do 108 | -- putStrLn "@@@ grinPush" 109 | -- (ans,_) <- evalStateT (whiz subBlock doexp finalExp whizState lam) (1,[]) 110 | -- return ans 111 | -- subBlock _ action = do 112 | -- (nn,x) <- get 113 | -- put (nn,mempty) 114 | -- r <- action 115 | -- (nn,_) <- get 116 | -- put (nn,x) 117 | -- return r 118 | -- doexp (v, exp) | isOmittable exp = do 119 | -- (nn,cv) <- get 120 | -- let npexp = makeDeps cv PExp { pexpUniq = nn, pexpBind = v, pexpExp = exp, pexpDeps = undefined, pexpProvides = undefined } 121 | -- put (nn+1,npexp:cv) 122 | -- return Nothing 123 | -- doexp (v, exp) = do 124 | -- exp <- fixupLet exp 125 | -- (v',exp') <- dropAny (Just v) exp 126 | -- return $ Just (v',exp') 127 | -- finalExp (exp::Exp) = do 128 | -- exp <- fixupLet exp 129 | -- (_,exp') <- dropAny Nothing exp 130 | -- return (exp'::Exp) 131 | -- fixupLet lt@Let { expDefs = defs, expBody = b } = do 132 | -- let def = (Set.fromList $ map funcDefName defs) 133 | -- f (e :>>= l :-> r) | Set.null (freeVars e `Set.intersection` def) = do 134 | -- exp <- f r 135 | -- return (e :>>= l :-> exp) 136 | -- f r = return $ updateLetProps lt { expBody = r } 137 | -- f b 138 | -- fixupLet exp = return exp 139 | -- dropAny mv (exp::Exp) = do 140 | -- (nn,xs) <- get 141 | -- let graph = newGraph xs pexpUniq pexpDeps 142 | -- deps = justDeps xs (freeVars exp) 143 | -- reached = reachable graph deps 144 | -- --dropped = case prefered reached exp of 145 | -- -- Just (x:_) | [] <- [ r | r <- reached, pexpUniq x `elem` pexpDeps r ] -> (reverse $ topSort $ newGraph (filter (/= x) reached) pexpUniq pexpDeps) ++ [x] 146 | -- -- _ -> reverse $ topSort $ newGraph reached pexpUniq pexpDeps 147 | -- dropped = reverse $ topSort $ newGraph reached pexpUniq pexpDeps 148 | -- ff pexp exp = pexpExp pexp :>>= pexpBind pexp :-> exp 149 | -- ebinds = [ Var v t | (v,t) <- Set.toList $ freeVars (map pexpBind dropped) ] 150 | -- (exp',mv') | Just vv <- mv = let mv' = tuple $ fromTuple vv ++ ebinds in (exp :>>= vv :-> Return mv',mv') 151 | -- | otherwise = (exp,unit) 152 | -- put (nn,[ x | x <- xs, pexpUniq x `notElem` (map pexpUniq reached) ]) 153 | -- when (not $ null dropped) $ lift $ do 154 | -- putStrLn "@@@ dropped" 155 | -- mapM_ Prelude.print dropped 156 | -- return (mv',foldr ff exp' dropped :: Exp) 157 | -- -- | preferentially pull definitons of the variable this returns right next to it as it admits a peephole optimization 158 | -- prefer (Store v@Var {}) = return v 159 | -- prefer (App fn [v@Var {}] _) | fn == funcEval = return v 160 | -- prefer (App fn [v@Var {},_] _)| fn == funcApply = return v 161 | -- prefer (App fn [v@Var {}] _) | fn == funcApply = return v 162 | -- prefer (Update _ v@Var {}) = return v 163 | -- prefer (Update v@Var {} _) = return v 164 | -- prefer _ = fail "no preference" 165 | -- prefered pexps exp = do 166 | -- v <- prefer exp 167 | -- return [ p | p <- pexps, v == pexpBind p] 168 | 169 | grinSpeculate :: Grin -> IO Grin 170 | grinSpeculate grin = do 171 | let ss = findSpeculatable grin 172 | when verbose $ putStrLn "Speculatable:" 173 | when verbose $ mapM_ Prelude.print ss 174 | let (grin',stats) = runStatM (performSpeculate ss grin) 175 | when verbose $ Stats.printStat "Speculate" stats 176 | return grin' 177 | 178 | performSpeculate specs grin = do 179 | let sset = fromList (map tagFlipFunction specs) :: GSet Tag 180 | let f (a,l) = mapBodyM h l >>= \l' -> return (a,l') 181 | h (BaseOp (StoreNode False) [NodeC t xs]) | t `member` sset = do 182 | let t' = tagFlipFunction t 183 | mtick $ "Optimize.speculate.store.{" ++ show t' 184 | return (App t' xs [TyNode] :>>= [n1] :-> demote n1) 185 | h e = mapExpExp h e 186 | fs <- mapM f (grinFuncs grin) 187 | return $ setGrinFunctions fs grin 188 | 189 | findSpeculatable :: Grin -> [Atom] 190 | findSpeculatable grin = ans where 191 | ans = [ x | Left (x,_) <- scc graph ] 192 | graph = newGraph [ (a,concatMap f (freeVars l :: [Tag])) | (a,_ :-> l) <- grinFuncs grin, isSpeculatable l, getType l == [TyNode] ] fst snd 193 | f t | tagIsSuspFunction t = [tagFlipFunction t] 194 | | tagIsFunction t = [t] 195 | | otherwise = [] 196 | isSpeculatable Return {} = True 197 | isSpeculatable (BaseOp (StoreNode _) _) = True 198 | isSpeculatable (BaseOp Promote _) = True 199 | isSpeculatable (BaseOp Demote _) = True 200 | isSpeculatable (x :>>= _ :-> y) = isSpeculatable x && isSpeculatable y 201 | isSpeculatable (Case e as) = all isSpeculatable [ e | _ :-> e <- as] 202 | isSpeculatable Prim { expPrimitive = p } = primIsConstant p 203 | isSpeculatable _ = False 204 | 205 | demote x = BaseOp Demote [x] 206 | -------------------------------------------------------------------------------- /src/Grin/Show.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, RecordWildCards, NoImplicitPrelude, FlexibleInstances, MultiParamTypeClasses #-} 2 | module Grin.Show( 3 | prettyFun, 4 | prettyExp, 5 | printGrin, 6 | hPrintGrin, 7 | graphGrin, 8 | render 9 | ) where 10 | import Prelude hiding ((<$>)) 11 | import Data.Char 12 | import Control.Monad.Writer(tell,when,forM_,execWriter) 13 | import Data.Maybe 14 | import System.IO 15 | import qualified Data.Map as Map 16 | import qualified Data.Set as Set 17 | 18 | import C.Prims 19 | import Data.Graph.Inductive.Graph(mkGraph) 20 | import Data.Graph.Inductive.Tree 21 | import Doc.DocLike 22 | import Doc.PPrint 23 | import Doc.Pretty 24 | import Grin.Grin 25 | import Grin.Noodle 26 | import Grin.Val 27 | import Name.VConsts 28 | import Options 29 | import StringTable.Atom 30 | import Support.CanType 31 | import Support.FreeVars 32 | import Util.Graphviz 33 | import qualified Cmm.Op as Op 34 | 35 | instance DocLike d => PPrint d Val where 36 | pprintAssoc _ _ v = prettyVal v 37 | 38 | instance PPrint Doc Exp where 39 | pprint v = prettyExp empty v 40 | 41 | pVar [] = empty 42 | pVar v = prettyVals v <+> operator "<- " 43 | 44 | pVar' v = prettyVals v <+> operator "<- " 45 | 46 | prettyVals [] = prettyVal Unit 47 | prettyVals [x] = prettyVal x 48 | prettyVals xs = tupled (map prettyVal xs) 49 | 50 | operator = text 51 | keyword = text 52 | tag x = text x 53 | func = text 54 | prim = text 55 | 56 | isComplex (_ :>>= _) = True 57 | isComplex _ = False 58 | 59 | isOneLine (_ :>>= _) = False 60 | isOneLine Case {} = False 61 | isOneLine Let {} = False 62 | isOneLine MkCont {} = False 63 | isOneLine _ = True 64 | 65 | {-# NOINLINE prettyExp #-} 66 | prettyExp vl (e1 :>>= v :-> e2) | isComplex e1 = align $ ((pVar' v) <> (prettyExp empty e1)) <$> prettyExp vl e2 67 | prettyExp vl (e1 :>>= v :-> e2) = align (prettyExp (pVar v) e1 <$> prettyExp vl e2) 68 | prettyExp vl (Return []) = vl <> keyword "return" <+> text "()" 69 | prettyExp vl (Return [v]) = vl <> keyword "return" <+> prettyVal v 70 | prettyExp vl (Return vs) = vl <> keyword "return" <+> tupled (map prettyVal vs) 71 | --prettyExp vl (Store v@Var {}) | getType v == tyDNode = vl <> keyword "demote" <+> prettyVal v 72 | --prettyExp vl (Store v) = vl <> keyword "store" <+> prettyVal v 73 | prettyExp vl (Error "" _) = vl <> prim "exitFailure" 74 | prettyExp vl (Error s _) = vl <> keyword "error" <+> tshow s 75 | prettyExp vl (BaseOp Eval [v]) = vl <> keyword "eval" <+> prettyVal v 76 | prettyExp vl (BaseOp Coerce {} [v]) = vl <> keyword "coerce" <+> prettyVal v 77 | prettyExp vl (BaseOp Apply {} vs) = vl <> keyword "apply" <+> hsep (map prettyVal vs) 78 | prettyExp vl (App a vs _) = vl <> func (fromAtom a) <+> hsep (map prettyVal vs) 79 | prettyExp vl Prim { expPrimitive = (Op (Op.BinOp bo _ _) _), expArgs = [x,y] } | Just (op,_) <- Op.binopInfix bo = vl <> prettyVal x <+> operator op <+> prettyVal y 80 | prettyExp vl Prim { expPrimitive = (Op (Op.BinOp bo _ _) _), expArgs = [x,y] } = vl <> prettyVal x <+> char '`' <> tshow bo <> char '`' <+> prettyVal y 81 | prettyExp vl Prim { expPrimitive = (Peek t), expArgs = [v] } = vl <> prim (show t) <> char '[' <> prettyVal v <> char ']' 82 | prettyExp vl Prim { expPrimitive = ap, expArgs = vs } = vl <> prim (pprint ap) <+> hsep (map prettyVal vs) 83 | prettyExp vl (GcRoots vs b) = vl <> keyword "withRoots" <> tupled (map prettyVal vs) <$> indent 2 (prettyExp empty b) 84 | prettyExp vl (BaseOp Overwrite [x,y]) = vl <> keyword "overwrite" <+> prettyVal x <+> prettyVal y 85 | prettyExp vl (BaseOp Redirect [x,y]) = vl <> keyword "redirect" <+> prettyVal x <+> prettyVal y 86 | prettyExp vl (BaseOp PokeVal [x,y]) = vl <> keyword "pokeVal" <+> prettyVal x <+> prettyVal y 87 | prettyExp vl (BaseOp PeekVal [x]) = vl <> keyword "peekVal" <+> prettyVal x 88 | prettyExp vl (BaseOp Promote [x]) = vl <> keyword "promote" <+> prettyVal x 89 | prettyExp vl (BaseOp NewRegister xs) = vl <> keyword "register" <+> tupled (map prettyVal xs) 90 | prettyExp vl (BaseOp WriteRegister [r,x]) = vl <> prettyVal r <+> keyword ":=" <+> prettyVal x 91 | prettyExp vl (BaseOp ReadRegister [r]) = vl <> keyword "*" <> prettyVal r 92 | prettyExp vl (BaseOp GcPush xs) = vl <> keyword "gcPush" <+> tupled (map prettyVal xs) 93 | prettyExp vl (BaseOp GcTouch xs) = vl <> keyword "gcTouch" <+> tupled (map prettyVal xs) 94 | prettyExp vl (BaseOp Demote [x]) = vl <> keyword "demote" <+> prettyVal x 95 | prettyExp vl (BaseOp (StoreNode b) [x]) = vl <> keyword ((if b then "d" else "i") ++ "store") <+> prettyVal x 96 | prettyExp vl (BaseOp (StoreNode b) [x,y]) = vl <> keyword ((if b then "d" else "i") ++ "store") <+> prettyVal x <> char '@' <> prettyVal y 97 | prettyExp vl (Case v vs) = vl <> keyword "case" <+> prettyVal v <+> keyword "of" <$> indent 2 (vsep (map f vs)) where 98 | f (~[v] :-> e) | isOneLine e = prettyVal v <+> operator "->" <+> prettyExp empty e 99 | f (~[v] :-> e) = prettyVal v <+> operator "->" <+> keyword "do" <$> indent 2 (prettyExp empty e) 100 | prettyExp vl NewRegion { expLam = (r :-> body)} = vl <> keyword "region" <+> text "\\" <> prettyVals r <+> text "-> do" <$> indent 2 (prettyExp empty body) 101 | --prettyExp vl MkCont { expCont = (r :-> body) } = vl <> keyword "continuation" <+> text "\\" <> prettyVal r <+> text "-> do" <$> indent 2 (prettyExp empty body) 102 | prettyExp vl Let { expDefs = defs, expBody = body, .. } = vl <> keyword (if expIsNormal then "let" else "let*") <$> indent 4 (vsep $ map f defs) <$> text " in" <$> indent 2 (prettyExp empty body) where 103 | f FuncDef { funcDefName = name, funcDefBody = as :-> body } = func (show name) <+> hsep (map prettyVal as) <+> operator "=" <+> keyword "do" <$> indent 2 (prettyExp empty body) 104 | prettyExp vl Alloc { expValue = val, expCount = Lit n _, expRegion = r }| n == 1 = vl <> keyword "alloc" <+> prettyVal val <+> text "at" <+> prettyVal r 105 | prettyExp vl Alloc { expValue = val, expCount = count, expRegion = r } = vl <> keyword "alloc" <+> prettyVal val <> text "[" <> prettyVal count <> text "]" <+> text "at" <+> prettyVal r 106 | prettyExp vl Call { expValue = Item t (TyCall fun _ _), expArgs = vs, expJump = jump } | fun `elem` [Function,LocalFunction] = vl <> f jump <+> func (fromAtom t) <+> hsep (map prettyVal vs) where 107 | f True = text "jump to" 108 | f False = text "call" 109 | prettyExp vl Call { expValue = Var v (TyCall fun _ _), expArgs = vs, expJump = jump} = vl <> f jump fun <+> pprint v <+> hsep (map prettyVal vs) where 110 | f False Continuation = text "cut to" 111 | f False Function = text "call" 112 | f True Function = text "jump to" 113 | f False Closure = text "enter" 114 | f True Closure = text "jump into" 115 | f x y = tshow (x,y) 116 | prettyExp vl Call { expValue = ValPrim ap [] (TyCall Primitive' _ _), expArgs = vs } = vl <> prim (tshow ap) <+> hsep (map prettyVal vs) 117 | prettyExp vl y = vl <> tshow y 118 | 119 | {-# NOINLINE prettyVal #-} 120 | prettyVal :: DocLike d => Val -> d 121 | prettyVal s | Just [] <- valToList s = text "[]" 122 | prettyVal s | Just st <- fromVal s = text $ show (st::String) 123 | prettyVal s | Just vs <- valToList s = list $ map prettyVal vs 124 | prettyVal (NodeC ch [t]) | ch == toAtom "CJhc.Prim.Char" = parens $ text "Char" <+> sc t where 125 | sc (Lit n t) | t == tCharzh = tshow (chr $ fromIntegral n) 126 | sc v = prettyVal v 127 | prettyVal (NodeC t []) = parens $ tag (fromAtom t) 128 | prettyVal (NodeC t vs) = parens $ tag (fromAtom t) <+> hsep (map prettyVal vs) 129 | prettyVal (Index p off) = prettyVal p <> char '[' <> prettyVal off <> char ']' 130 | prettyVal v@Var {} = tshow v 131 | prettyVal (Lit i _) = tshow i 132 | prettyVal (Const v) = char '&' <> prettyVal v 133 | prettyVal (ValUnknown ty) = text "?::" <> tshow ty 134 | prettyVal Unit = text "()" 135 | prettyVal (Item a ty) = tshow a <> text "::" <> tshow ty 136 | prettyVal (ValPrim aprim args ty) = f aprim args where 137 | f aprim [] = pprint aprim <> text "::" <> tshow ty 138 | f ((Op (Op.BinOp bo _ _) _)) [x,y] | Just (op,prec) <- Op.binopInfix bo = parens (pprintPrec prec x <+> text op <+> pprintPrec prec y) 139 | f ((Op (Op.BinOp bo _ _) _)) [x,y] = parens $ pprintPrec 1 x <+> char '`' <> tshow bo <> char '`' <+> pprintPrec 1 y 140 | f aprim xs = pprint aprim <> tupled (map prettyVal xs) <> text "::" <> tshow ty 141 | 142 | instance DocLike d => PPrint d Var where 143 | pprint (V i) = text $ 'v':show i 144 | --pv (V 0) = char '_' 145 | --pv (V i) = char 'v' <> tshow i 146 | 147 | prettyFun :: (Atom,Lam) -> Doc 148 | prettyFun (n,(as :-> e)) = func (fromAtom n) <+> hsep (map prettyVal as) <+> operator "=" <+> keyword "do" <$> indent 2 (prettyExp empty e) 149 | 150 | render :: Doc -> String 151 | render doc = displayS (renderPretty 0.95 (optColumns options) doc) "" 152 | 153 | printGrin :: Grin -> IO () 154 | printGrin grin = hPrintGrin stderr grin 155 | 156 | hPrintGrin :: Handle -> Grin -> IO () 157 | hPrintGrin handle grin@Grin { grinCafs = cafs } = do 158 | when (not $ null cafs) $ do 159 | hPutStrLn handle "-- Cafs" 160 | mapM_ (hPutStrLn handle) $ map (\(x,y) -> show x ++ " := " ++ render (prettyVal y)) cafs 161 | hPutStrLn handle "-- Functions" 162 | forM_ (grinFuncs grin) $ \ f@(n,l :-> e) -> do 163 | hPutStrLn handle . render $ func (fromAtom n) <+> operator "::" <+> tupled (map (tshow . getType) l) <+> operator "->" <+> tupled (map tshow (getType e)) 164 | hPutStrLn handle (render $ prettyFun f) 165 | hPutStrLn handle "" 166 | 167 | {-# NOINLINE graphGrin #-} 168 | 169 | graphGrin :: Grin -> String 170 | graphGrin grin = graphviz' gr [] fnode fedge where 171 | nodes = zip [0..] (grinFuncs grin) 172 | nodeMap = Map.fromList [ (y,x) | (x,(y,_)) <- nodes] 173 | gr :: Gr (Atom,Lam) CallType 174 | gr = mkGraph nodes [ (n,n2,tc) | (n,(_,_ :-> l)) <- nodes, (tc,fv) <- Set.toList (freeVars l), n2 <- maybeToList $ Map.lookup fv nodeMap ] 175 | fnode :: (Atom,Lam) -> [(String,String)] 176 | fnode (x,_ :-> e) = [("label",show x)] 177 | ++ (if hasError e then [("color","red")] else []) 178 | ++ (if x `elem` grinEntryPointNames grin then [("shape","box")] else []) 179 | fedge :: CallType -> [(String,String)] 180 | fedge TailCall = [] 181 | fedge StandardCall = [("style","dotted")] 182 | 183 | hasError x = isNothing (hasError' x) 184 | hasError' Error {} = Nothing 185 | hasError' e = mapExpExp hasError' e 186 | 187 | data CallType = TailCall | StandardCall 188 | deriving(Ord,Show,Eq) 189 | 190 | instance FreeVars Exp (Set.Set (CallType,Atom)) where 191 | freeVars (a :>>= _ :-> b) = freeVars b `Set.union` Set.map (\ (_ :: CallType,y) -> (StandardCall, y)) (freeVars a) 192 | freeVars (App a _ _) = Set.singleton (TailCall,a) 193 | freeVars e = execWriter $ mapExpExp (\e -> tell (freeVars e) >> return e) e 194 | -------------------------------------------------------------------------------- /src/Grin/Show.hs-boot: -------------------------------------------------------------------------------- 1 | module Grin.Show where 2 | 3 | import Doc.Pretty 4 | import Atom 5 | import {-# SOURCE #-} Grin.Grin 6 | 7 | prettyFun :: (Atom.Atom,Grin.Grin.Lam) -> Doc.Pretty.Doc 8 | prettyExp :: Doc.Pretty.Doc -> Grin.Grin.Exp -> Doc.Pretty.Doc 9 | prettyVal :: Grin.Grin.Val -> Doc.Pretty.Doc 10 | -------------------------------------------------------------------------------- /src/Grin/StorageAnalysis.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Grin.StorageAnalysis(storeAnalyze) where 3 | 4 | import Control.Monad.Identity 5 | import Control.Monad.Writer 6 | import Data.Maybe 7 | import qualified Data.Map as Map 8 | import qualified Data.Set as Set 9 | 10 | import Grin.Grin 11 | import Grin.Noodle 12 | import Grin.Val 13 | import Options 14 | import StringTable.Atom 15 | import Support.FreeVars 16 | import Support.Tickle 17 | import Util.Gen 18 | import Util.UnionSolve 19 | import Util.UniqueMonad 20 | import qualified FlagOpts as FO 21 | 22 | data T = S | E 23 | deriving(Eq,Show) 24 | 25 | instance Fixable T where 26 | join S S = S 27 | join _ _ = E 28 | 29 | meet E E = E 30 | meet _ _ = S 31 | 32 | isTop x = E == x 33 | isBottom x = S == x 34 | 35 | eq = (==) 36 | 37 | lte E S = False 38 | lte _ _ = True 39 | 40 | data Vr 41 | = Vb !Var -- ^ inner variable 42 | | Va !Atom !Int -- ^ function argument 43 | | Vr !Var -- ^ region variable 44 | deriving(Eq,Ord) 45 | 46 | instance Show Vr where 47 | showsPrec _ (Vb v) = shows v 48 | showsPrec _ (Va a i) = shows (a,i) 49 | showsPrec _ (Vr (V n)) = showChar 'r' . shows n 50 | 51 | {-# NOINLINE storeAnalyze #-} 52 | storeAnalyze :: Grin -> IO Grin 53 | storeAnalyze grin | fopts FO.Jgc = return grin 54 | storeAnalyze grin = do 55 | --dumpGrin "storeAnalyze1" grin 56 | let (grin',cs) = execUniq1 $ runWriterT (mapGrinFuncsM firstLam grin) 57 | --dumpGrin "storeAnalyze2" grin' 58 | (rm,res) <- solve (const $ return ()) cs 59 | -- (rm,res) <- solve putStrLn cs 60 | -- putStrLn "----------------------------" 61 | -- mapM_ (\ (x,y) -> putStrLn $ show x ++ " -> " ++ show y) (Map.toList rm) 62 | -- putStrLn "----------------------------" 63 | -- mapM_ print (Map.elems res) 64 | -- putStrLn "----------------------------" 65 | let cmap = Map.filterWithKey fm $ Map.map (lower . fromJust . flip Map.lookup res) rm 66 | lower (ResultJust _ j) = j 67 | lower ResultBounded { resultLB = Nothing } = S 68 | lower _ = error "StorageAnalysis.storeAnalyze: bad." 69 | fm _ E = False 70 | fm (Vr _) _ = True 71 | fm (Va _ _) _ = True 72 | fm _ _ = False 73 | mapM_ (\ (x,y) -> putStrLn $ show x ++ " -> " ++ show y) (Map.toList cmap) 74 | let grin'' = runIdentity $ tickleM (lastLam cmap) grin' 75 | return grin'' 76 | 77 | isHeap TyNode = True 78 | isHeap TyINode = True 79 | --isHeap TyPtr {} = True 80 | isHeap _ = False 81 | 82 | firstLam fname lam = g Nothing fname lam where 83 | g wtd fname (as :-> body) = do 84 | tell $ mconcat [ Left (Vb v) `equals` Left (Va fname n) | (n,Var v t) <- zip naturals as, isHeap t ] 85 | let f wtd (BaseOp (StoreNode sh) [n@(NodeC _ vs)]) = do 86 | vu <- V `liftM` newUniq 87 | g wtd [[Vr vu]] 88 | tell $ mconcat [ Left (Vr vu) `islte` Left v | v' <- toVs vs, v <- v' ] 89 | return (BaseOp (StoreNode sh) [n,Var vu TyRegion]) 90 | f wtd (e :>>= as :-> body) = do 91 | e' <- f (Just as) e 92 | body' <- f wtd body 93 | return (e' :>>= as :-> body') 94 | f wtd (Case e as) = Case e `liftM` mapM (tickleM (f wtd)) as 95 | f wtd (Return xs) = g wtd (toVs xs) >> return (Return xs) 96 | f wtd e@(BaseOp Promote xs) = g wtd (toVs xs) >> return e 97 | f wtd e@(BaseOp Demote xs) = g wtd (toVs xs) >> return e 98 | f wtd e@(BaseOp Redirect xs) = g Nothing (toVs xs) >> return e 99 | f wtd e@(BaseOp Overwrite [Var v _,n]) = do tell $ mconcat [ Left (Vb v) `islte` Left r | r <- concat $ toVs [n] ] ; return e 100 | f wtd e@(App fn vs ty) = do 101 | tell $ mconcat [ Left (Va fn n) `islte` Left (Vb v) | (n,Var v t) <- zip naturals vs, isHeap t ] 102 | return e 103 | f wtd e@(Let { expDefs = defs, expBody = b }) = do 104 | defs' <- mapM (tickleM (g' wtd)) defs 105 | b <- f wtd b 106 | return $ updateLetProps e { expDefs = defs', expBody = b } 107 | f wtd e = do 108 | let zs = Set.toList (Set.map (Vb . fst) $ Set.filter (isHeap . snd) (freeVars e)) 109 | tell $ mconcat [ Right E `islte` Left r | r <- zs ]; 110 | return e 111 | 112 | g Nothing vs = tell $ mconcat [ Right E `islte` Left v | v' <- vs, v <- v' ] 113 | g (Just as) vs = tell $ mconcat [ Left a `islte` Left v | (a',v') <- zip (toVs as) vs, a <- a', v <- v'] 114 | 115 | toVs :: [Val] -> [[Vr]] 116 | toVs xs = f xs [] where 117 | f [] rs = reverse rs 118 | f (x:xs) rs = f xs (Set.toList (Set.map (Vb . fst) $ Set.filter (isHeap . snd) (freeVars x)):rs) 119 | b <- f wtd body 120 | return (as :-> b) 121 | g' wtd (fname,b) = do 122 | b <- g wtd fname b 123 | return (fname,b) 124 | 125 | lastLam :: Map.Map Vr T -> Lam -> Identity Lam 126 | lastLam cmap lam = tickleM f lam where 127 | f (BaseOp (StoreNode sh) [n,Var r TyRegion]) = do 128 | case Map.lookup (Vr r) cmap of 129 | Just S -> return (BaseOp (StoreNode sh) [n,region_stack]) 130 | _ -> return (BaseOp (StoreNode sh) [n]) 131 | f e = tickleM f e 132 | -------------------------------------------------------------------------------- /src/Grin/Val.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | module Grin.Val( 3 | FromVal(..), 4 | ToVal(..), 5 | tn_2Tup, 6 | valToList, 7 | cChar, 8 | cWord, 9 | cInt, 10 | convertName, 11 | region_heap, 12 | region_atomic_heap, 13 | region_stack, 14 | region_block 15 | ) where 16 | 17 | import Data.Char 18 | 19 | import Cmm.Number 20 | import Grin.Grin 21 | import Name.Name 22 | import Name.Names 23 | import Name.VConsts 24 | import StringTable.Atom 25 | 26 | nil = convertName dc_EmptyList 27 | cons = convertName dc_Cons 28 | cChar = convertName dc_Char 29 | cWord = convertName dc_Word 30 | cInt = convertName dc_Int 31 | tn_2Tup = convertName $ nameTuple DataConstructor 2 32 | tn_Boolzh = convertName dc_Boolzh 33 | tn_unit = convertName dc_Unit 34 | 35 | -- This allocates data on the heap. 36 | region_heap = Item (toAtom "heap") TyRegion 37 | -- This allocates data on the atomic heap. 38 | region_atomic_heap = Item (toAtom "atomicHeap") TyRegion 39 | -- This allocates data in the innermost enclosing region, including implicit regions. 40 | region_block = Item (toAtom "block") TyRegion 41 | -- This allocates data on the stack, generally equivalent to 'block' for most back ends. 42 | region_stack = Item (toAtom "stack") TyRegion 43 | 44 | instance ConNames Val where 45 | vTrue = NodeC tn_Boolzh [toUnVal (1 :: Int)] 46 | vFalse = NodeC tn_Boolzh [toUnVal (0 :: Int)] 47 | vUnit = NodeC tn_unit [] 48 | 49 | class ToVal a where 50 | toVal :: a -> Val 51 | toUnVal :: a -> Val 52 | toUnVal x = toVal x 53 | 54 | class FromVal a where 55 | fromVal :: Monad m => Val -> m a 56 | fromUnVal :: Monad m => Val -> m a 57 | fromUnVal x = fromVal x 58 | 59 | instance ToVal Bool where 60 | toVal True = vTrue 61 | toVal False = vFalse 62 | 63 | instance ToVal a => ToVal [a] where 64 | toVal [] = NodeC nil [] 65 | toVal (x:xs) = NodeC cons [Const (toVal x),Const (toVal xs)] 66 | instance ToVal (Val,Val) where 67 | toVal (x,y) = NodeC tn_2Tup [x,y] 68 | 69 | instance ToVal Char where 70 | toVal c = NodeC cChar [toUnVal c] 71 | toUnVal c = Lit (fromIntegral $ ord c) tIntzh 72 | instance ToVal Int where 73 | toVal c = NodeC cInt [toUnVal c] 74 | toUnVal c = Lit (fromIntegral c) tIntzh 75 | 76 | instance ToVal Val where 77 | toVal x = x 78 | 79 | instance FromVal Int where 80 | fromVal (NodeC _ [Lit i _]) | Just x <- toIntegral i = return x 81 | fromVal n = fail $ "Val is not Int: " ++ show n 82 | fromUnVal (Lit i _) | Just x <- toIntegral i = return x 83 | fromUnVal n = fail $ "Val is not UnInt: " ++ show n 84 | instance FromVal Char where 85 | fromVal (NodeC _ [Lit i _]) | Just x <- toIntegral i, x >= ord minBound && x <= ord maxBound = return (chr x) 86 | fromVal n = fail $ "Val is not Char: " ++ show n 87 | fromUnVal (Lit i _) | Just x <- toIntegral i, x >= ord minBound && x <= ord maxBound = return (chr x) 88 | fromUnVal n = fail $ "Val is not UnChar: " ++ show n 89 | 90 | instance FromVal a => FromVal [a] where 91 | fromVal (NodeC n []) | n == nil = return [] 92 | fromVal (NodeC n [Const a,Const b]) | n == cons = do 93 | x <- fromVal a 94 | xs <- fromVal b 95 | return (x:xs) 96 | fromVal n = fail $ "Val is not [a]: " ++ show n 97 | 98 | instance FromVal Bool where 99 | fromVal n 100 | | n == toVal True = return True 101 | | n == toVal False = return False 102 | fromVal n = fail $ "Val is not Bool: " ++ show n 103 | instance FromVal Val where 104 | fromVal n = return n 105 | 106 | valToList (NodeC n []) | n == nil = return [] 107 | valToList (NodeC n [a,Const b]) | n == cons = do 108 | xs <- valToList b 109 | return (a:xs) 110 | valToList n = fail $ "Val is not [a]: " ++ show n 111 | 112 | convertName n = toAtom (t':s) where 113 | (t,s) = fromName n 114 | t' | t == TypeConstructor = 'T' 115 | | t == DataConstructor = 'C' 116 | | t == Val = 'f' 117 | | otherwise = error $ "convertName: " ++ show (t,s) 118 | -------------------------------------------------------------------------------- /src/Grin/Whiz.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, ParallelListComp, FlexibleContexts, GADTs #-} 2 | module Grin.Whiz(whiz, fizz, WhizState, whizState, normalizeGrin,normalizeGrin', applySubstE, applySubst, whizExps) where 3 | 4 | import Control.Monad.Identity 5 | import Control.Monad.State 6 | import Control.Monad.Writer 7 | import Util.GMap 8 | import Util.HasSize 9 | import Util.SetLike 10 | import qualified Data.Set as Set 11 | 12 | import Grin.Grin 13 | import Grin.Noodle 14 | import Support.CanType 15 | 16 | type WhizState = Either (Set.Set Int) Int 17 | type WhizEnv = GMap Var Val 18 | 19 | whizState :: WhizState 20 | whizState = Left mempty 21 | 22 | --normalizeGrin :: Grin -> Grin 23 | --normalizeGrin grin@Grin { grinFunctions = fs } = grin { grinFunctions = f fs [] (Right 1) } where 24 | -- f [] xs _ = xs 25 | -- f ((a,(Tup vs,fn)):xs) ys set = f xs ((a,(Tup vs',fn')):ys) set' where 26 | -- (Identity ((NodeC _ vs',fn'),set')) = whiz return return set (NodeC tagHole vs , fn) 27 | normalizeGrin :: Grin -> Grin 28 | normalizeGrin grin = setGrinFunctions (f (grinFuncs grin) [] (Right 1)) grin where 29 | f [] xs _ = reverse xs 30 | f ((a,lm):xs) ys set = f xs ((a,lm'):ys) set' where 31 | (Identity (lm',set')) = fizz (\_ x -> x) (return . Just) return set lm 32 | 33 | normalizeGrin' :: Grin -> Grin 34 | normalizeGrin' grin = setGrinFunctions (f (grinFuncs grin) []) grin where 35 | f [] xs = reverse xs 36 | f ((a,lm):xs) ys = f xs ((a,lm'):ys) where 37 | (Identity (lm',_)) = whiz (\_ x -> x) (return . Just) return (Right 1) lm 38 | 39 | whizExps :: Monad m => (Exp -> m Exp) -> Lam -> m Lam 40 | whizExps f l = liftM fst $ whiz (\_ x -> x) (\(p,e) -> f e >>= \e' -> return (Just (p,e'))) f whizState l 41 | 42 | -- | magic traversal and flattening routine. 43 | -- whiz traverses Grin code and right assosiates it as well as renaming and 44 | -- repeated variables along the way. 45 | -- in addition, it provides a nice monadic traversal of the flattened renamed code suitable 46 | -- for a wide range of grin -> grin transformations. 47 | -- basically, you may use 'whiz' to perform tranformations which do not require lookahead, and depend 48 | -- only on the code that happened before. 49 | -- note that a case is presented after all of its sub code blocks have been processed 50 | -- Whiz also vectorizes tuple->tuple assignments, breaking them into individual assignments 51 | -- for its components to better aid future optimizations. 52 | 53 | whiz :: Monad m => 54 | (forall a . [Val] -> m a -> m a) -- ^ called for each sub-code block, such as in case statements 55 | -> (([Val],Exp) -> m (Maybe ([Val],Exp))) -- ^ routine to transform or omit simple bindings 56 | -> (Exp -> m Exp) -- ^ routine to transform final statement in code block 57 | -> WhizState -- ^ Initial state 58 | -> Lam -- ^ input lambda expression 59 | -> m (Lam,WhizState) 60 | whiz sub te tf inState start = res where 61 | res = runStateT (dc mempty start) inState 62 | f (a :>>= (v :-> b)) xs env = f a ((env,v,b):xs) env 63 | f a@(Return (xs@(_:_:_))) ((senv,p@(ys@(_:_:_)),b):rs) env | length xs == length ys = do 64 | Return xs <- g env a 65 | (ys,env') <- renamePattern p 66 | ts <- lift $ mapM te [([y],Return [x]) | x <- xs | y <- ys ] 67 | z <- f b rs (env' `mappend` senv) 68 | let h [] = z 69 | h ((p,v):rs) = v :>>= p :-> h rs 70 | return $ h [ (p,v) | Just (p,v) <- ts] 71 | f a ((senv,p,b):xs) env = do 72 | a <- g env a 73 | (p,env') <- renamePattern p 74 | x <- lift $ te (p,a) 75 | z <- f b xs (env' `mappend` senv) 76 | case x of 77 | Just (p',a') -> do 78 | return $ a' :>>= (p' :-> z) 79 | Nothing -> do 80 | return z 81 | f x [] env = do 82 | x <- g env x 83 | lift $ tf x 84 | g env (Case v as) = do 85 | v <- applySubst env v 86 | as <- mapM (dc env) as 87 | return $ Case v as 88 | g env (GcRoots vs body) = do 89 | vs <- mapM (applySubst env) vs 90 | body <- f body [] env 91 | return $ GcRoots vs body 92 | -- g env lt@Let { expDefs = defs, expBody = Let { expDefs = defs', expBody = body } } = g env lt { expDefs = defs `mappend` defs', expBody = body } 93 | g env lt@Let { expDefs = defs, expBody = body } = do 94 | body <- f body [] env 95 | let f def@FuncDef { funcDefName = n, funcDefBody = b } = do 96 | b <- dc env b 97 | return $ createFuncDef True n b 98 | defs <- mapM f defs 99 | return $ updateLetProps lt { expBody = body, expDefs = defs } 100 | g env x = applySubstE env x 101 | dc env (p :-> e) = do 102 | (p,env') <- renamePattern p 103 | g <- get 104 | (z,g) <- lift $ sub p $ runStateT (f e [] (env' `mappend` env)) g 105 | put g 106 | return (p :-> z) 107 | 108 | -- | magic traversal and flattening routine. 109 | -- whiz traverses Grin code and right assosiates it as well as renaming and 110 | -- repeated variables along the way. 111 | -- in addition, it provides a nice monadic traversal of the flattened renamed code suitable 112 | -- for a wide range of grin -> grin transformations. 113 | -- basically, you may use 'whiz' to perform tranformations which do not require lookahead, and depend 114 | -- only on the code that happened before. 115 | -- note that a case is presented after all of its sub code blocks have been processed 116 | -- Whiz also vectorizes tuple->tuple assignments, breaking them into individual assignments 117 | -- for its components to better aid future optimizations. 118 | -- fizz is similar to whiz, but processes things in 'bottom-up' order. 119 | -- fizz also removes all statements past an Error. 120 | 121 | fizz :: Monad m => 122 | (forall a . [Val] -> m a -> m a) -- ^ called for each sub-code block, such as in case statements 123 | -> (([Val],Exp) -> m (Maybe ([Val],Exp))) -- ^ routine to transform or omit simple bindings 124 | -> (Exp -> m Exp) -- ^ routine to transform final statement in code block 125 | -> WhizState -- ^ Initial state 126 | -> Lam -- ^ input lambda expression 127 | -> m (Lam,WhizState) 128 | fizz sub te tf inState start = res where 129 | res = runStateT (dc mempty start) inState 130 | f (a :>>= (v :-> b)) xs env = f a ((env,v,b):xs) env 131 | f a@(Return (xs@(_:_:_))) ((senv,p@ys,b):rs) env | length xs == length ys = do 132 | Return xs <- g env a 133 | (ys,env') <- renamePattern p 134 | z <- f b rs (env' `mappend` senv) 135 | ts <- lift $ mapM te (reverse [([y],Return [x]) | x <- xs | y <- ys ]) 136 | let h [] = z 137 | h ((p,v):rs) = v :>>= p :-> h rs 138 | return $ h [ (p,v) | Just (p,v) <- reverse ts] 139 | f (Error msg ty) [] env = do 140 | lift $ tf (Error msg ty) 141 | f (Error msg ty) ((_,_,b):xs) env = do 142 | f (Error msg (getType b)) xs env 143 | f a ((senv,p,b):xs) env = do 144 | a <- g env a 145 | (p,env') <- renamePattern p 146 | z <- f b xs (env' `mappend` senv) 147 | x <- lift $ te (p,a) 148 | case x of 149 | Just (p',a') -> do 150 | return $ a' :>>= (p' :-> z) 151 | Nothing -> do 152 | return z 153 | f x [] env = do 154 | x <- g env x 155 | lift $ tf x 156 | g env (Case v as) = do 157 | v <- applySubst env v 158 | as <- mapM (dc env) as 159 | return $ Case v as 160 | g env (GcRoots vs body) = do 161 | vs <- mapM (applySubst env) vs 162 | body <- f body [] env 163 | return $ GcRoots vs body 164 | g env lt@Let { expDefs = defs, expBody = body } = do 165 | body <- f body [] env 166 | let f def@FuncDef { funcDefName = n, funcDefBody = b } = do 167 | b <- dc env b 168 | return $ createFuncDef True n b 169 | defs <- mapM f defs 170 | return $ updateLetProps lt { expBody = body, expDefs = defs } 171 | g env x = applySubstE env x 172 | dc env (p :-> e) = do 173 | (p,env') <- renamePattern p 174 | g <- get 175 | (z,g) <- lift $ sub p $ runStateT (f e [] (env' `mappend` env)) g 176 | put g 177 | return (p :-> z) 178 | 179 | applySubstE env x = mapExpVal (applySubst env) x 180 | 181 | applySubst env x = f x where 182 | f var@(Var v _) 183 | | Just n <- mlookup v env = return n 184 | f x = mapValVal f x 185 | 186 | renamePattern :: MonadState (WhizState) m => [Val] -> m ([Val],WhizEnv) 187 | renamePattern x = runWriterT (mapM f x) where 188 | f :: MonadState (WhizState) m => Val -> WriterT (WhizEnv) m Val 189 | f (Var v t) = do 190 | v' <- lift $ newVarName v 191 | let nv = Var v' t 192 | tell (msingleton v nv) 193 | return nv 194 | f (NodeC t vs) = do 195 | vs' <- mapM f vs 196 | return $ NodeC t vs' 197 | f (Index a b) = return Index `ap` f a `ap` f b 198 | f x = return x 199 | 200 | newVarName :: MonadState WhizState m => Var -> m Var 201 | newVarName (V sv) = do 202 | s <- get 203 | case s of 204 | Left s -> do 205 | let nv = v sv 206 | v n | n `member` s = v (n + size s) 207 | | otherwise = n 208 | put (Left $! insert nv s) 209 | return (V nv) 210 | Right n -> do 211 | put $! (Right $! (n + 1)) 212 | return $ V n 213 | -------------------------------------------------------------------------------- /src/Info/Info.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} 2 | module Info.Info( 3 | T, 4 | Info(..), 5 | Entry(..), 6 | HasInfo(..), 7 | Info.Info.lookup, 8 | Info.Info.lookupTyp, 9 | insertWith, 10 | insert, 11 | limit, 12 | maybeInsert, 13 | singleton, 14 | member, 15 | delete, 16 | fetch, 17 | extend, 18 | empty, 19 | infoMap, 20 | infoMapM 21 | ) where 22 | 23 | import Data.Dynamic 24 | import Data.Monoid 25 | import qualified Data.List as List 26 | 27 | import GenUtil 28 | import Util.HasSize 29 | 30 | -- extensible type indexed product 31 | 32 | type T = Info 33 | 34 | data Entry = Entry { 35 | entryThing :: Dynamic, 36 | entryString :: String, 37 | entryType :: !TypeRep 38 | } 39 | 40 | instance Eq Entry where 41 | a == b = entryType a == entryType b 42 | 43 | instance Show Entry where 44 | showsPrec _ x = showString (entryString x) 45 | 46 | instance Ord Entry where 47 | compare a b = compare (show $ entryType a) (show $ entryType b) 48 | 49 | newtype Info = Info [Entry] 50 | deriving(HasSize,Typeable) 51 | 52 | -- the Eq and Ord instances for info make them all seem equivalent. 53 | instance Eq Info where 54 | _ == _ = True 55 | instance Ord Info where 56 | compare _ _ = EQ 57 | 58 | instance Show Info where 59 | show (Info ds) = show (sortUnder (show . entryType) ds) 60 | 61 | --instance Data Info where 62 | -- toConstr = undefined 63 | -- dataTypeOf = undefined 64 | 65 | instance Monoid Info where 66 | mempty = empty 67 | mappend (Info as) (Info bs) = Info (List.union as bs) 68 | 69 | class HasInfo a where 70 | getInfo :: a -> Info 71 | modifyInfo :: (Info -> Info) -> a -> a 72 | 73 | instance HasInfo Info where 74 | getInfo = id 75 | modifyInfo f x = f x 76 | 77 | lookupTyp :: forall a . Typeable a => a -> Info -> Maybe a 78 | lookupTyp a = f where 79 | f (Info mp) = g mp 80 | typ = typeOf (undefined :: a) 81 | g [] = Nothing 82 | g (x:xs) | entryType x == typ = fromDynamic (entryThing x) 83 | g (_:xs) = g xs 84 | 85 | lookup :: forall a m . (Monad m,Typeable a) => Info -> m a 86 | lookup = maybe (fail $ "Info: could not find: " ++ show typ) return . f where 87 | typ = typeOf (undefined :: a) 88 | f = lookupTyp (undefined :: a) 89 | 90 | insertWith :: (Show a,Typeable a) => (a -> a -> a) -> a -> Info -> Info 91 | insertWith f newx (Info mp) = Info (g mp) where 92 | g [] = [newEntry newx] 93 | g (x:xs) | entryType x == typ = newEntry (f newx (fromDyn (entryThing x) (error "can't happen"))):xs 94 | | otherwise = x:g xs 95 | typ = typeOf newx 96 | 97 | newEntry :: (Typeable a,Show a) => a -> Entry 98 | newEntry x = Entry { entryThing = toDyn x, entryString = show x, entryType = typeOf x } 99 | 100 | insert :: (Show a,Typeable a) => a -> Info -> Info 101 | insert newx (Info nfo) = Info $ newEntry newx:f nfo where 102 | f [] = [] 103 | f (x:xs) | entryType x == typ = xs 104 | | otherwise = x:f xs 105 | typ = typeOf newx 106 | 107 | maybeInsert :: (Show a, Typeable a) => Maybe a -> Info -> Info 108 | maybeInsert Nothing = id 109 | maybeInsert (Just x) = insert x 110 | 111 | singleton :: (Show a,Typeable a) => a -> Info 112 | singleton x = insert x empty 113 | 114 | infoMapM :: (Typeable a, Typeable b, Show b, Monad m) => (a -> m b) -> Info -> m Info 115 | infoMapM f i = case Info.Info.lookup i of 116 | Just x -> do 117 | n <- f x 118 | return (insert n (delete x i)) 119 | Nothing -> return i 120 | 121 | infoMap :: (Typeable a, Typeable b, Show b) => (a -> b) -> Info -> Info 122 | infoMap f i = case Info.Info.lookup i of 123 | Just x -> insert (f x) (delete x i) 124 | Nothing -> i 125 | 126 | delete :: (Typeable a) => a -> Info -> Info 127 | delete x info = deleteTyp (typeOf x) info 128 | 129 | deleteTyp :: TypeRep -> Info -> Info 130 | deleteTyp typ (Info mp) = Info (f mp) where 131 | f [] = [] 132 | f (x:xs) | entryType x == typ = xs 133 | | otherwise = x:f xs 134 | 135 | limit :: [TypeRep] -> Info -> Info 136 | limit trs (Info mp) = Info (f mp) where 137 | f (x:xs) | entryType x `elem` trs = x:f xs 138 | | otherwise = f xs 139 | f [] = [] 140 | 141 | fetch :: (Monoid a, Typeable a) => Info -> a 142 | fetch info = maybe mempty id (Info.Info.lookup info) 143 | 144 | member :: (Typeable a) => a -> Info -> Bool 145 | member x (Info s) = f s where 146 | typ = typeOf x 147 | f [] = False 148 | f (x:xs) | entryType x == typ = True 149 | | otherwise = f xs 150 | 151 | extend :: (Show a,Monoid a, Typeable a) => a -> Info -> Info 152 | extend x info = insertWith mappend x info 153 | 154 | empty :: Info 155 | empty = Info [] 156 | -------------------------------------------------------------------------------- /src/Name/Internals.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} 2 | module Name.Internals(NameType(..),Module(..),Name(..),QualifiedName,UnqualifiedName,ClassName,FieldName,QuotedName,UnQuotedName,forgeName,nameCompare) where 3 | 4 | import StringTable.Atom 5 | import Data.Binary 6 | import Data.Char 7 | import Data.Data 8 | 9 | {- 10 | - TODO: 11 | We cache pertinent information about a name in a single byte for easy access. 12 | [qocrrss0] [q-xrr110] 13 | ss 0 term q 0 not quoted 14 | 1 type 1 quoted 15 | 2 sort x 0 class 16 | rr 0 unqualified 1 field 17 | 1 qualified c 0 not constructor 18 | 2 prim 1 constructor 19 | 3 composition o 0 not operator 20 | 1 operator 21 | -} 22 | 23 | ------------- 24 | -- Name types 25 | ------------- 26 | -- 27 | newtype Name = Name Atom 28 | deriving(Ord,Eq,Typeable,Binary,Data,ToAtom,FromAtom) 29 | 30 | -- Used for documentation 31 | type QualifiedName = Name 32 | type UnqualifiedName = Name 33 | type ClassName = Name 34 | type FieldName = Name 35 | type QuotedName = Name 36 | type UnQuotedName = Name 37 | 38 | data NameType 39 | = TypeConstructor 40 | | DataConstructor 41 | | ClassName 42 | | TypeVal 43 | | Val 44 | | SortName 45 | | FieldLabel 46 | | RawType 47 | | UnknownType 48 | | QuotedName 49 | deriving(Ord,Eq,Enum,Read,Show) 50 | 51 | newtype Module = Module Atom 52 | deriving(Eq,Data,Typeable,ToAtom,FromAtom) 53 | 54 | instance Ord Module where 55 | compare (Module x) (Module y) = x `atomCompare` y 56 | 57 | instance Show Module where 58 | showsPrec _ (Module n) = shows n 59 | 60 | forgeName :: NameType -> Maybe Module -> String -> Name 61 | forgeName t Nothing i = Name $ toAtom $ (chr $ fromEnum t + ord '1'):";" ++ i 62 | forgeName t (Just m) i = Name $ toAtom $ (chr $ ord '1' + fromEnum t):show m ++ ";" ++ i 63 | 64 | -- lexigraphic comparison 65 | Name x `nameCompare` Name y = x `atomCompare` y 66 | -------------------------------------------------------------------------------- /src/Name/Name.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, ViewPatterns, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-} 2 | module Name.Name( 3 | Module(), 4 | Name, 5 | Class, 6 | NameType(..), 7 | ToName(..), 8 | ffiExportName, 9 | fromTypishHsName, 10 | fromValishHsName, 11 | getIdent, 12 | getModule, 13 | isConstructorLike, 14 | isTypeNamespace, 15 | isValNamespace, 16 | isOpLike, 17 | mapName, 18 | mapName', 19 | nameName, 20 | nameParts, 21 | nameType, 22 | parseName, 23 | qualifyName, 24 | setModule, 25 | quoteName, 26 | fromQuotedName, 27 | toModule, 28 | FieldName, 29 | ClassName, 30 | toUnqualified, 31 | removeUniquifier, 32 | -- new interface 33 | unMkName, 34 | mkName, 35 | mkComplexName, 36 | emptyNameParts, 37 | mkNameType, 38 | NameParts(..), 39 | nameTyLevel_u, 40 | nameTyLevel_s, 41 | typeLevel, 42 | kindLevel, 43 | termLevel, 44 | originalUnqualifiedName, 45 | deconstructName 46 | ) where 47 | 48 | import Data.Char 49 | import Util.Std 50 | 51 | import C.FFI 52 | import Doc.DocLike 53 | import Doc.PPrint 54 | import GenUtil 55 | import Name.Internals 56 | import StringTable.Atom 57 | import Ty.Level 58 | import Name.Prim 59 | 60 | isTypeNamespace TypeConstructor = True 61 | isTypeNamespace ClassName = True 62 | isTypeNamespace TypeVal = True 63 | isTypeNamespace _ = False 64 | 65 | isValNamespace DataConstructor = True 66 | isValNamespace Val = True 67 | isValNamespace _ = False 68 | 69 | ----------------- 70 | -- name definiton 71 | ----------------- 72 | 73 | isConstructorLike n = isUpper x || x `elem` (":(" :: String) || xs == "->" || xs == "[]" where 74 | (_,_,xs@(x:_)) = nameParts n 75 | 76 | isOpLike n = x `elem` ("!#$%&*+./<=>?@\\^-~:|" :: String) where 77 | (_,_,(x:_)) = nameParts n 78 | 79 | fromTypishHsName, fromValishHsName :: Name -> Name 80 | fromTypishHsName name 81 | | nameType name == QuotedName = name 82 | | isConstructorLike name = toName TypeConstructor name 83 | | otherwise = toName TypeVal name 84 | fromValishHsName name 85 | | nameType name == QuotedName = name 86 | | isConstructorLike name = toName DataConstructor name 87 | | otherwise = toName Val name 88 | 89 | createName :: NameType -> Module -> String -> Name 90 | createName _ (Module "") i = error $ "createName: empty module " ++ i 91 | createName _ m "" = error $ "createName: empty ident " ++ show m 92 | createName t m i = Name $ toAtom $ (chr $ ord '1' + fromEnum t):show m ++ ";" ++ i 93 | 94 | createUName :: NameType -> String -> Name 95 | createUName _ "" = error $ "createUName: empty ident" 96 | createUName t i = Name $ toAtom $ (chr $ fromEnum t + ord '1'):";" ++ i 97 | 98 | class ToName a where 99 | toName :: NameType -> a -> Name 100 | fromName :: Name -> (NameType, a) 101 | 102 | instance ToName (String,String) where 103 | toName nt (m,i) = createName nt (Module $ toAtom m) i 104 | fromName n = case nameParts n of 105 | (nt,Just (Module m),i) -> (nt,(show m,i)) 106 | (nt,Nothing,i) -> (nt,("",i)) 107 | 108 | instance ToName (Module,String) where 109 | toName nt (m,i) = createName nt m i 110 | fromName n = case nameParts n of 111 | (nt,Just m,i) -> (nt,(m,i)) 112 | (nt,Nothing,i) -> (nt,(Module "",i)) 113 | 114 | instance ToName (Maybe Module,String) where 115 | toName nt (Just m,i) = createName nt m i 116 | toName nt (Nothing,i) = createUName nt i 117 | fromName n = case nameParts n of 118 | (nt,a,b) -> (nt,(a,b)) 119 | 120 | instance ToName Name where 121 | toName nt i | nt == ct = i 122 | | otherwise = toName nt (x,y) where 123 | (ct,x,y) = nameParts i 124 | fromName n = (nameType n,n) 125 | 126 | instance ToName String where 127 | toName nt i = createUName nt i 128 | fromName n = (nameType n, mi ) where 129 | mi = case snd $ fromName n of 130 | (Just (Module m),i) -> show m ++ "." ++ i 131 | (Nothing,i) -> i 132 | 133 | getModule :: Monad m => Name -> m Module 134 | getModule n = case nameParts n of 135 | (_,Just m,_) -> return m 136 | _ -> fail "Name is unqualified." 137 | 138 | getIdent :: Name -> String 139 | getIdent n = case nameParts n of 140 | (_,_,s) -> s 141 | 142 | toUnqualified :: Name -> Name 143 | toUnqualified n = case nameParts n of 144 | (_,Nothing,_) -> n 145 | (t,Just _,i) -> toName t (Nothing :: Maybe Module,i) 146 | 147 | qualifyName :: Module -> Name -> Name 148 | qualifyName m n = case nameParts n of 149 | (t,Nothing,n) -> toName t (Just m, n) 150 | _ -> n 151 | 152 | setModule :: Module -> Name -> Name 153 | setModule m n = qualifyName m $ toUnqualified n 154 | 155 | parseName :: NameType -> String -> Name 156 | parseName t name = toName t (intercalate "." ms, intercalate "." (ns ++ [last sn])) where 157 | sn = (split (== '.') name) 158 | (ms,ns) = span validMod (init sn) 159 | validMod (c:cs) = isUpper c && all (\c -> isAlphaNum c || c `elem` ("_'" :: String)) cs 160 | validMod _ = False 161 | 162 | nameType :: Name -> NameType 163 | nameType (Name a) = toEnum $ fromIntegral ( a `unsafeByteIndex` 0) - ord '1' 164 | 165 | nameName :: Name -> Name 166 | nameName n = n 167 | 168 | nameParts :: Name -> (NameType,Maybe Module,String) 169 | nameParts n@(Name atom) = (nameType n,a,b) where 170 | (a,b) = f $ tail (fromAtom atom) 171 | f (';':xs) = (Nothing,xs) 172 | f xs = (Just $ Module (toAtom a),b) where 173 | (a,_:b) = span (/= ';') xs 174 | 175 | instance Show Name where 176 | showsPrec _ n = f n where 177 | f (fromQuotedName -> Just n) = showChar '`' . f n 178 | f (nameType -> UnknownType) = showChar '¿' . (g $ nameParts n) 179 | f n = g $ nameParts n 180 | g (_,Just a,b) = shows a . showChar '.' . showString b 181 | g (_,Nothing,b) = showString b 182 | 183 | instance DocLike d => PPrint d Name where 184 | pprint n = text (show n) 185 | 186 | mapName :: (Module -> Module,String -> String) -> Name -> Name 187 | mapName (f,g) n = case nameParts n of 188 | (nt,Nothing,i) -> toName nt (g i) 189 | (nt,Just m,i) -> toName nt (Just (f m :: Module),g i) 190 | mapName' :: (Maybe Module -> Maybe Module) -> (String -> String) -> Name -> Name 191 | mapName' f g n = case nameParts n of 192 | (nt,m,i) -> toName nt (f m,g i) 193 | 194 | ffiExportName :: FfiExport -> Name 195 | ffiExportName (FfiExport cn _ cc _ _) = toName Val (Module "FE@", show cc ++ "." ++ cn) 196 | type Class = Name 197 | 198 | ------------- 199 | -- Quoting 200 | ------------- 201 | 202 | quoteName :: Name -> Name 203 | quoteName (Name n) = createUName QuotedName (fromAtom n) 204 | fromQuotedName :: Name -> Maybe Name 205 | fromQuotedName n = case nameParts n of 206 | (QuotedName,Nothing,s) -> Just $ Name (toAtom s) 207 | _ -> Nothing 208 | 209 | -------------- 210 | -- Modules 211 | -------------- 212 | 213 | toModule :: String -> Module 214 | toModule s = Module $ toAtom s 215 | 216 | -------------- 217 | --prefered api 218 | -------------- 219 | mkName :: TyLevel -> Bool -> Maybe Module -> String -> Name 220 | mkName l b mm s = toName (mkNameType l b) (mm,s) 221 | 222 | data NameParts = NameParts { 223 | nameLevel :: TyLevel, 224 | nameQuoted :: Bool, 225 | nameConstructor :: Bool, 226 | nameModule :: Maybe Module, 227 | nameUniquifier :: Maybe Int, 228 | nameIdent :: String 229 | } 230 | 231 | emptyNameParts = NameParts { 232 | nameLevel = termLevel, 233 | nameQuoted = False, 234 | nameConstructor = False, 235 | nameModule = Nothing, 236 | nameUniquifier = Nothing, 237 | nameIdent = "(empty)" 238 | } 239 | 240 | mkComplexName :: NameParts -> Name 241 | mkComplexName NameParts { .. } = qn $ toName (mkNameType nameLevel nameConstructor) (nameModule,ident) where 242 | ident = maybe id (\c s -> show c ++ "_" ++ s) nameUniquifier nameIdent 243 | qn = if nameQuoted then quoteName else id 244 | 245 | unMkName :: Name -> NameParts 246 | unMkName name = NameParts { .. } where 247 | (nameQuoted,nameModule,_,uqn,nameUniquifier) = deconstructName name 248 | (_,_,nameIdent) = nameParts uqn 249 | nameConstructor = isConstructor name 250 | nameLevel = tyLevelOf name 251 | 252 | -- internal 253 | mkNameType :: TyLevel -> Bool -> NameType 254 | mkNameType l b = (f l b) where 255 | f l b | l == termLevel = if b then DataConstructor else Val 256 | | l == typeLevel = if b then TypeConstructor else TypeVal 257 | | l == kindLevel && b = SortName 258 | f l b = error ("mkName: invalid " ++ show (l,b)) 259 | 260 | unRenameString :: String -> (Maybe Int,String) 261 | unRenameString s = case span isDigit s of 262 | (ns@(_:_),'_':rs) -> (Just (read ns),rs) 263 | (_,_) -> (Nothing,s) 264 | 265 | -- deconstruct name into all its possible parts 266 | -- does not work on quoted names. 267 | deconstructName :: Name -> (Bool,Maybe Module,Maybe UnqualifiedName,UnqualifiedName,Maybe Int) 268 | deconstructName name | Just name <- fromQuotedName name = case deconstructName name of 269 | (_,a,b,c,d) -> (True,a,b,c,d) 270 | deconstructName name = f nt where 271 | (nt,mod,id) = nameParts name 272 | (mi,id') = unRenameString id 273 | f _ = (False,mod,Nothing,toName nt id',mi) 274 | 275 | originalUnqualifiedName :: Name -> Name 276 | originalUnqualifiedName n = case deconstructName n of 277 | (_,_,_,n,_) -> n 278 | 279 | --constructName :: Maybe Module -> Maybe UnqualifiedName -> UnqualifiedName -> Maybe Int -> Name 280 | --constructName mm 281 | 282 | ---------------- 283 | -- Parameterized 284 | ---------------- 285 | 286 | -- Goal, get rid of hardcoded NameType, move pertinent info into cache byte 287 | 288 | instance HasTyLevel Name where 289 | getTyLevel n = f (nameType n) where 290 | f DataConstructor = Just termLevel 291 | f Val = Just termLevel 292 | f RawType = Just typeLevel 293 | f TypeConstructor = Just typeLevel 294 | f TypeVal = Just typeLevel 295 | f SortName 296 | | n == s_HashHash = Just $ succ kindLevel 297 | | n == s_StarStar = Just $ succ kindLevel 298 | | otherwise = Just kindLevel 299 | f _ = Nothing 300 | 301 | isConstructor :: Name -> Bool 302 | isConstructor n = f (nameType n) where 303 | f TypeConstructor = True 304 | f DataConstructor = True 305 | f SortName = True 306 | f QuotedName = isConstructor $ fromJust (fromQuotedName n) 307 | f _ = False 308 | 309 | nameTyLevel_s tl n = nameTyLevel_u (const tl) n 310 | 311 | nameTyLevel_u f (fromQuotedName -> Just qn) = quoteName $ nameTyLevel_u f qn 312 | nameTyLevel_u f n = case getTyLevel n of 313 | Nothing -> n 314 | Just cl | cl == cl' -> n 315 | | otherwise -> toName (mkNameType cl' (isConstructor n)) n 316 | where cl' = f cl 317 | 318 | removeUniquifier name = mkComplexName (unMkName name) { nameUniquifier = Nothing } 319 | -------------------------------------------------------------------------------- /src/Name/Names.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, ViewPatterns #-} 2 | -- | All hardcoded names in the compiler should go in here 3 | -- the convention is 4 | -- v_foo for values 5 | -- tc_foo for type constructors 6 | -- dc_foo for data constructors 7 | -- s_foo for sort names 8 | -- rt_foo for raw names 9 | -- class_foo for classes 10 | 11 | module Name.Names(module Name.Name,module Name.Names,module Name.Prim) where 12 | 13 | import Data.Char(isDigit) 14 | 15 | import Name.Name 16 | import Name.Prim 17 | import Name.VConsts 18 | import Ty.Level 19 | 20 | instance TypeNames Name where 21 | tInt = tc_Int 22 | tBool = tc_Bool 23 | tInteger = tc_Integer 24 | tChar = tc_Char 25 | tUnit = tc_Unit 26 | 27 | tIntzh = rt_bits32 28 | tEnumzh = rt_bits16 29 | tCharzh = tc_Char_ 30 | -- tWorld__ = tc_World__ 31 | 32 | --No tuple instance because it is easy to get the namespace wrong. use 'nameTuple' 33 | --instance ToTuple Name where 34 | -- toTuple n = toName DataConstructor (toTuple n :: (String,String)) 35 | 36 | nameTuple t 0 = toName t dc_Unit -- $ -- (toTuple n:: (String,String)) -- Qual (HsIdent ("(" ++ replicate (n - 1) ',' ++ ")")) 37 | nameTuple _ n | n < 2 = error "attempt to create tuple of length < 2" 38 | nameTuple t n = toName t $ (toTuple n:: (String,String)) -- Qual (HsIdent ("(" ++ replicate (n - 1) ',' ++ ")")) 39 | 40 | unboxedNameTuple t n = toName t $ "(#" ++ show n ++ "#)" 41 | fromUnboxedNameTuple n = case show n of 42 | '(':'#':xs | (ns@(_:_),"#)") <- span isDigit xs -> return (read ns::Int) 43 | _ -> fail $ "Not unboxed tuple: " ++ show n 44 | 45 | instance FromTupname Name where 46 | fromTupname name | m == mod_JhcPrimPrim = fromTupname (nn::String) where 47 | (_,(m,nn)) = fromName name 48 | fromTupname _ = fail "not a tuple" 49 | 50 | sFuncNames = FuncNames { 51 | func_equals = v_equals, 52 | func_fromInteger = v_fromInteger, 53 | func_fromInt = v_fromInt, 54 | func_fromRational = v_fromRational, 55 | func_negate = v_negate, 56 | func_runExpr = v_runExpr, 57 | func_runMain = v_runMain, 58 | func_runNoWrapper = v_runNoWrapper, 59 | func_runRaw = v_runRaw 60 | } 61 | 62 | -------------- 63 | -- tuple names 64 | -------------- 65 | 66 | name_TupleConstructor :: TyLevel -> Int -> Name 67 | name_TupleConstructor l 1 = error $ "name_TupleConstructor called for unary tuple at " ++ show l 68 | name_TupleConstructor l 0 = nameTyLevel_u (const l) dc_Unit 69 | name_TupleConstructor l n = mkName l True (Just mod_JhcPrimPrim) ("(" ++ replicate (n - 1) ',' ++ ")") 70 | 71 | name_UnboxedTupleConstructor :: TyLevel -> Int -> Name 72 | name_UnboxedTupleConstructor l n = mkName l True Nothing ("(#" ++ show n ++ "#)") 73 | 74 | -- checks whether it is either a normal or unboxed tuple. Bool return is whether 75 | -- it is boxed. 76 | fromName_Tuple :: Name -> Maybe (Bool,TyLevel,Int) 77 | fromName_Tuple n | n == dc_Unit = Just (True,termLevel,0) 78 | fromName_Tuple n | n == tc_Unit = Just (True,typeLevel,0) 79 | fromName_Tuple n = f (getTyLevel n, deconstructName n) where 80 | f (Just tl,(False,Just m,Nothing,uq,Nothing)) | 81 | m == mod_JhcPrimPrim, 82 | Just n <- fromTupname (show uq)= Just (True,tl,n) 83 | f (Just tl,(False,Nothing,Nothing,uq,Nothing)) | 84 | Just n <- fromUnboxedNameTuple uq = Just (False,tl,n) 85 | f _ = Nothing 86 | 87 | fromName_UnboxedTupleConstructor :: Name -> Maybe (TyLevel,Int) 88 | fromName_UnboxedTupleConstructor (fromName_Tuple -> Just (False,tl,n)) = Just (tl,n) 89 | fromName_UnboxedTupleConstructor _ = Nothing 90 | 91 | fromName_TupleConstructor :: Name -> Maybe (TyLevel,Int) 92 | fromName_TupleConstructor (fromName_Tuple -> Just (True,tl,n)) = Just (tl,n) 93 | fromName_TupleConstructor _ = Nothing 94 | -------------------------------------------------------------------------------- /src/Name/VConsts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveFunctor, DeriveTraversable #-} 2 | module Name.VConsts where 3 | 4 | import Data.Foldable 5 | import Data.Traversable 6 | 7 | -- This is much more verbose/complicated than it needs be. 8 | 9 | class TypeNames a where 10 | tInt :: a 11 | tRational :: a 12 | tChar :: a 13 | tIntzh :: a 14 | tEnumzh :: a 15 | tCharzh :: a 16 | tBool :: a 17 | tUnit :: a 18 | tString :: a 19 | tInteger :: a 20 | tWorld__ :: a 21 | 22 | tInt = error "tInt" 23 | tRational = error "tRational" 24 | tChar = error "tChar" 25 | tIntzh = error "tIntzh" 26 | tEnumzh = error "tEnumzh" 27 | tCharzh = error "tCharzh" 28 | tBool = error "tBool" 29 | tUnit = error "tUnit" 30 | tString = error "tString" 31 | tInteger = error "tInteger" 32 | tWorld__ = error "tWorld" 33 | 34 | class ConNames a where 35 | vTrue :: a 36 | vFalse :: a 37 | vCons :: a 38 | vUnit :: a 39 | 40 | vTrue = error "vTrue" 41 | vFalse = error "vFalse" 42 | vCons = error "vCons" 43 | vUnit = error "vUnit" 44 | 45 | class FromTupname a where 46 | fromTupname :: Monad m => a -> m Int 47 | 48 | instance FromTupname String where 49 | fromTupname ('(':s) | (cs,")") <- span (== ',') s, lc <- length cs, lc > 0 = return $! (lc + 1) 50 | fromTupname xs = fail $ "fromTupname: not tuple " ++ xs 51 | 52 | instance FromTupname (String,String) where 53 | fromTupname ("Jhc.Prim.Prim",n) = fromTupname n 54 | fromTupname xs = fail $ "fromTupname: not tuple " ++ show xs 55 | 56 | class ToTuple a where 57 | toTuple :: Int -> a 58 | 59 | instance ToTuple String where 60 | toTuple n = '(': replicate (n - 1) ',' ++ ")" 61 | 62 | instance ToTuple (String,String) where 63 | toTuple n = ("Jhc.Prim.Prim",toTuple n) 64 | 65 | -- | various functions needed for desugaring. 66 | data FuncNames a = FuncNames { 67 | func_equals :: a, 68 | func_fromInt :: a, 69 | func_fromInteger :: a, 70 | func_fromRational :: a, 71 | func_negate :: a, 72 | func_runExpr :: a, 73 | func_runMain :: a, 74 | func_runNoWrapper :: a, 75 | func_runRaw :: a 76 | } deriving(Functor, Traversable, Foldable) 77 | -------------------------------------------------------------------------------- /src/PackedString.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface, MagicHash, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} 2 | module PackedString ( 3 | PackedString, 4 | packString, 5 | packAddr_, 6 | unpackPS, 7 | ) where 8 | 9 | import Data.Binary 10 | import Data.Generics 11 | import Data.Monoid 12 | import GHC.Exts 13 | import System.IO.Unsafe 14 | import qualified Data.ByteString as BS 15 | import qualified Data.ByteString.UTF8 as BSU 16 | import qualified Data.ByteString.Unsafe as BS 17 | 18 | newtype PackedString = PS BS.ByteString 19 | deriving(Typeable,Binary,Eq,Ord,Monoid,Data) 20 | 21 | instance Show PackedString where 22 | showsPrec p ps r = showsPrec p (unpackPS ps) r 23 | 24 | -- | Convert a 'String' into a 'PackedString' 25 | packString :: String -> PackedString 26 | packString str = PS (BSU.fromString str) 27 | 28 | packAddr_ :: Addr# -> PackedString 29 | packAddr_ addr = PS $ unsafePerformIO (BS.unsafePackAddress addr) 30 | 31 | unpackPS :: PackedString -> String 32 | unpackPS (PS bs) = BSU.toString bs 33 | 34 | instance IsString PackedString where 35 | fromString = packString 36 | -------------------------------------------------------------------------------- /src/Stats.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, GeneralizedNewtypeDeriving, OverlappingInstances #-} 2 | module Stats( 3 | -- mutable 4 | Stats, 5 | new, 6 | tick, 7 | setPrintStats, 8 | ticks, 9 | theStats, 10 | isEmpty, 11 | null, 12 | Stats.print, 13 | clear, 14 | combine, 15 | -- pure 16 | printStat, 17 | printLStat, 18 | Stat, 19 | Stats.singleton, 20 | Stats.singleStat, 21 | prependStat, 22 | -- monad 23 | MonadStats(..), 24 | StatT, 25 | StatM, 26 | mtick, 27 | mtick', 28 | mticks, 29 | runStatT, 30 | runStatIO, 31 | runStatM, 32 | -- combined 33 | tickStat, 34 | readStat 35 | ) where 36 | 37 | import Data.Binary 38 | import GHC.Generics (Generic) 39 | 40 | import Util.Std 41 | import Control.Monad.Reader 42 | import Control.Monad.Writer.Strict 43 | import Data.IORef 44 | import Data.Tree 45 | import Prelude hiding(null) 46 | import System.IO.Unsafe 47 | import qualified Data.Map as Map 48 | import qualified Prelude(null) 49 | 50 | import StringTable.Atom 51 | import qualified Doc.Chars as C 52 | import qualified Util.IntBag as IB 53 | 54 | splitUp :: Int -> String -> [String] 55 | splitUp n str = filter (not . Prelude.null) (f n str) where 56 | f 0 str = [] 57 | f n str = case span (`notElem` "/.{") str of 58 | (x,"") -> [x] 59 | (x,('/':rs)) -> x:f (n - 1) rs 60 | (x,('.':rs)) -> x:f n rs 61 | (x,('{':rs)) -> case span (/= '}') rs of 62 | (a,'}':b) -> x:a:f n b 63 | (a,"") -> [x,a] 64 | _ -> error "this can't happen" 65 | _ -> error "this can't happen" 66 | 67 | print greets stats = do 68 | l <- toList stats 69 | let fs = createForest 0 $ sort [(splitUp (-1) $ fromAtom x,y) | (x,y) <- l] 70 | mapM_ putStrLn $ ( draw . fmap p ) (Node (greets,0) fs) where 71 | p (x,0) = x 72 | p (x,n) = x ++ ": " ++ show n 73 | 74 | createForest :: a -> [([String],a)] -> Forest (String,a) 75 | createForest def xs = map f gs where 76 | f [(xs,ys)] = Node (intercalate "." xs,ys) [] 77 | f xs@((x:_,_):_) = Node (x,def) (createForest def [ (xs,ys) | (_:xs@(_:_),ys)<- xs]) 78 | f _ = error "createForest: should not happen." 79 | gs = groupBy (\(x:_,_) (y:_,_) -> x == y) xs 80 | 81 | draw :: Tree String -> [String] 82 | draw (Node x ts0) = x : drawSubTrees ts0 83 | where drawSubTrees [] = [] 84 | drawSubTrees [t] = 85 | {-[vLine] :-} shift lastBranch " " (draw t) 86 | drawSubTrees (t:ts) = 87 | {-[vLine] :-} shift branch (C.vLine ++ " ") (draw t) ++ drawSubTrees ts 88 | 89 | branch = C.lTee ++ C.hLine 90 | lastBranch = C.llCorner ++ C.hLine 91 | 92 | shift first other = zipWith (++) (first : repeat other) 93 | --vLine = chr 0x254F 94 | 95 | -- Pure varients 96 | 97 | newtype Stat = Stat IB.IntBag 98 | deriving(Eq,Ord,Monoid,Generic) 99 | 100 | instance Binary Stat 101 | 102 | prependStat :: String -> Stat -> Stat 103 | prependStat name (Stat m) = Stat $ IB.fromList [ (fromAtom $ mappend (toAtom $ "{" ++ name ++ "}.") (unsafeIntToAtom x),y) | (x,y) <- IB.toList m ] 104 | 105 | printStat greets (Stat s) = do 106 | let fs = createForest 0 $ sort [(splitUp (-1) $ fromAtom (unsafeIntToAtom x),y) | (x,y) <- IB.toList s] 107 | mapM_ putStrLn $ ( draw . fmap p ) (Node (greets,0) fs) where 108 | p (x,0) = x 109 | p (x,n) = x ++ ": " ++ show n 110 | 111 | printLStat n greets (Stat s) = do 112 | let fs = createForest 0 $ [ (x,y) | (x,y) <- Map.toList $ Map.fromListWith (+) [( splitUp n (fromAtom (unsafeIntToAtom x)),y) | (x,y) <- IB.toList s]] 113 | mapM_ putStrLn $ ( draw . fmap p ) (Node (greets,0) fs) where 114 | p (x,0) = x 115 | p (x,n) = x ++ ": " ++ show n 116 | 117 | -------------- 118 | -- monad stats 119 | -------------- 120 | 121 | class Monad m => MonadStats m where 122 | mticks' :: Int -> Atom -> m () 123 | mtickStat :: Stat -> m () 124 | 125 | newtype StatT m a = StatT (WriterT Stat m a) 126 | deriving(MonadIO, Functor, MonadFix, MonadTrans, Monad, Applicative) 127 | 128 | runStatT :: Monad m => StatT m a -> m (a,Stat) 129 | runStatT (StatT m) = runWriterT m 130 | 131 | data StatM a = StatM a !Stat 132 | 133 | instance Functor StatM where 134 | fmap f (StatM a s) = StatM (f a) s 135 | 136 | instance Applicative StatM where 137 | StatM f s1 <*> StatM y s2 = StatM (f y) (s1 `mappend` s2) 138 | pure x = StatM x mempty 139 | 140 | instance Monad StatM where 141 | StatM _ s1 >> StatM y s2 = StatM y (s1 `mappend` s2) 142 | return x = StatM x mempty 143 | StatM x s1 >>= y = case y x of StatM z s2 -> StatM z (s1 `mappend` s2) 144 | 145 | instance Stats.MonadStats StatM where 146 | mticks' 0 k = StatM () mempty 147 | mticks' n k = StatM () $ Stats.singleStat n k 148 | mtickStat s = StatM () s 149 | 150 | runStatM :: StatM a -> (a,Stat) 151 | runStatM (StatM a s) = (a,s) 152 | 153 | -- These are inlined so the 'toAtom' can become a caf and be shared 154 | {-# INLINE mtick #-} 155 | {-# INLINE mticks #-} 156 | mtick k = mticks 1 k 157 | mtick' k = mticks' 1 k 158 | mticks 0 _ = return () 159 | mticks n k = let k' = toAtom k in k' `seq` n `seq` mticks' n k' 160 | 161 | instance MonadStats Identity where 162 | mticks' _ _ = return () 163 | mtickStat _ = return () 164 | 165 | instance MonadReader r m => MonadReader r (StatT m) where 166 | ask = lift $ ask 167 | local f (StatT m) = StatT $ local f m 168 | 169 | instance (Monad m, Monad (t m), MonadTrans t, MonadStats m) => MonadStats (t m) where 170 | mticks' n k = lift $ mticks' n k 171 | mtickStat s = lift $ mtickStat s 172 | 173 | instance Monad m => MonadStats (StatT m) where 174 | mticks' n k = StatT $ tell (Stat $ IB.msingleton (fromAtom k) n) 175 | mtickStat s = StatT $ tell s 176 | 177 | singleton n = Stat $ IB.singleton (fromAtom $ toAtom n) 178 | 179 | singleStat :: ToAtom a => Int -> a -> Stat 180 | singleStat 0 _ = mempty 181 | singleStat n k = Stat $ IB.msingleton (fromAtom $ toAtom k) n 182 | 183 | null (Stat r) = IB.null r 184 | 185 | instance MonadStats IO where 186 | mticks' 0 _ = return () 187 | mticks' n a = do 188 | p <- readIORef printStats 189 | when p (putStrLn $ (show a ++ ": " ++ show n)) 190 | ticks theStats n a 191 | mtickStat (Stat s) = do 192 | tickStat theStats (Stat s) 193 | p <- readIORef printStats 194 | when p $ forM_ (IB.toList s) $ \ (x,y) -> do 195 | putStrLn (show (unsafeIntToAtom x) ++ ": " ++ show y) 196 | 197 | -------------------- 198 | -- Stateful IO stats 199 | -------------------- 200 | 201 | newtype Stats = Stats (IORef Stat) 202 | 203 | {-# NOINLINE theStats #-} 204 | theStats :: Stats 205 | theStats = unsafePerformIO new 206 | 207 | {-# NOINLINE printStats #-} 208 | printStats :: IORef Bool 209 | printStats = unsafePerformIO $ newIORef False 210 | 211 | setPrintStats :: Bool -> IO () 212 | setPrintStats b = writeIORef printStats b 213 | 214 | combine :: Stats -> Stats -> IO () 215 | combine (Stats s1) (Stats s2) = do 216 | s <- readIORef s2 217 | modifyIORef s1 (mappend s) 218 | 219 | new = Stats `liftM` newIORef mempty 220 | 221 | clear (Stats h) = writeIORef h mempty 222 | 223 | toList (Stats r) = do 224 | Stat s <- readIORef r 225 | return [(unsafeIntToAtom x,y) | (x,y) <- IB.toList s] 226 | 227 | isEmpty (Stats r) = null `liftM` readIORef r 228 | 229 | tick stats k = ticks stats 1 k 230 | 231 | ticks (Stats r) c k = modifyIORef r (mappend $ singleStat c k) 232 | 233 | ----------------- 234 | -- pure + mutable 235 | ----------------- 236 | 237 | tickStat :: Stats -> Stat -> IO () 238 | tickStat (Stats r) s = modifyIORef r (mappend s) 239 | 240 | runStatIO :: MonadIO m => Stats -> StatT m a -> m a 241 | runStatIO stats action = do 242 | (a,s) <- runStatT action 243 | liftIO $ tickStat stats s 244 | return a 245 | 246 | readStat :: Stats -> IO Stat 247 | readStat (Stats r) = readIORef r 248 | -------------------------------------------------------------------------------- /src/StringTable/Atom.hsc: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -XForeignFunctionInterface -XTypeSynonymInstances -XDeriveDataTypeable #-} 2 | {-# LANGUAGE MagicHash, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving, UnliftedFFITypes #-} 3 | module StringTable.Atom( 4 | Atom(), 5 | ToAtom(..), 6 | FromAtom(..), 7 | HasHash(..), 8 | intToAtom, 9 | isValidAtom, 10 | unsafeIntToAtom, 11 | atomCompare, 12 | unsafeByteIndex, 13 | dumpTable, 14 | dumpToFile, 15 | addrToAtom_, 16 | dumpStringTableStats 17 | ) where 18 | 19 | #include "StringTable_cbits.h" 20 | 21 | import Data.Binary 22 | import Data.Binary.Get 23 | import Data.Binary.Put 24 | import Data.Bits 25 | import Data.Data 26 | import Data.Monoid 27 | import System.IO.Unsafe (unsafePerformIO) 28 | import Foreign.Marshal 29 | import Foreign.Storable 30 | import Foreign.C 31 | import GHC.Exts 32 | import qualified Data.ByteString as BS 33 | import qualified Data.ByteString.Internal as BS 34 | import qualified Data.ByteString.UTF8 as BS(fromString,toString) 35 | import qualified Data.ByteString.Unsafe as BS 36 | 37 | import Util.GMap 38 | import Util.SetLike 39 | import Util.HasSize 40 | 41 | newtype Atom = Atom (#type atom_t) 42 | deriving(Typeable,Eq,Data,Ord) 43 | 44 | class FromAtom a where 45 | fromAtom :: Atom -> a 46 | fromAtomIO :: Atom -> IO a 47 | 48 | fromAtomIO a = return (fromAtom a) 49 | fromAtom a = unsafePerformIO (fromAtomIO a) 50 | 51 | class ToAtom a where 52 | toAtom :: a -> Atom 53 | toAtomIO :: a -> IO Atom 54 | 55 | toAtomIO a = return (toAtom a) 56 | toAtom a = unsafePerformIO (toAtomIO a) 57 | 58 | class HasHash a where 59 | hash32 :: a -> Word32 60 | 61 | instance HasHash Atom where 62 | hash32 a = let (x,y) = fromAtom a :: CStringLen in 63 | unsafePerformIO $ hash2 0 x (fromIntegral y) 64 | 65 | instance HasHash BS.ByteString where 66 | hash32 bs = unsafePerformIO $ do 67 | BS.unsafeUseAsCStringLen bs $ \ (x,y) -> hash2 0 x (fromIntegral y) 68 | 69 | instance HasHash String where 70 | hash32 s = unsafePerformIO $ withCStringLen s $ 71 | \ (x,y) -> hash2 0 x (fromIntegral y) 72 | 73 | instance FromAtom (String -> String) where 74 | fromAtom x = shows (fromAtom x :: String) 75 | 76 | instance ToAtom Atom where 77 | toAtom x = x 78 | 79 | instance FromAtom Atom where 80 | fromAtom x = x 81 | 82 | instance ToAtom Char where 83 | toAtom x = toAtom [x] 84 | 85 | instance ToAtom CStringLen where 86 | toAtomIO (cs,len) = do 87 | if (len > (#const MAX_ENTRY_SIZE)) 88 | then fail "StringTable: atom is too big" 89 | else stAdd cs (fromIntegral len) 90 | 91 | instance ToAtom CString where 92 | toAtomIO cs = do 93 | len <- BS.c_strlen cs 94 | toAtomIO (cs,fromIntegral len :: Int) 95 | 96 | instance ToAtom String where 97 | toAtomIO s = toAtomIO (BS.fromString s) 98 | 99 | instance FromAtom String where 100 | fromAtom = BS.toString . fromAtom 101 | 102 | instance ToAtom BS.ByteString where 103 | toAtomIO bs = BS.unsafeUseAsCStringLen bs toAtomIO 104 | 105 | instance FromAtom CStringLen where 106 | fromAtom a@(Atom v) = (stPtr a,fromIntegral $ 107 | (v `shiftR` (#const ATOM_LEN_SHIFT)) .&. (#const ATOM_LEN_MASK)) 108 | 109 | instance FromAtom Word where 110 | fromAtom (Atom i) = fromIntegral i 111 | 112 | instance FromAtom Int where 113 | fromAtom (Atom i) = fromIntegral i 114 | 115 | instance FromAtom BS.ByteString where 116 | fromAtomIO a = do 117 | sl <- fromAtomIO a :: IO CStringLen 118 | BS.unsafePackCStringLen sl 119 | 120 | instance Monoid Atom where 121 | mempty = toAtom BS.empty 122 | mappend x y = unsafePerformIO $ atomAppend x y 123 | 124 | instance IsString Atom where 125 | fromString = toAtom 126 | 127 | instance Show Atom where 128 | showsPrec _ atom = (fromAtom atom ++) 129 | 130 | instance Read Atom where 131 | readsPrec _ s = [ (toAtom s,"") ] 132 | 133 | intToAtom :: Monad m => Int -> m Atom 134 | intToAtom i = if isValidAtom i then return (Atom $ fromIntegral i) else 135 | fail $ "intToAtom: " ++ show i 136 | 137 | isValidAtom :: Int -> Bool 138 | isValidAtom i = odd i 139 | 140 | unsafeIntToAtom :: Int -> Atom 141 | unsafeIntToAtom x = Atom (fromIntegral x) 142 | 143 | unsafeByteIndex :: Atom -> Int -> Word8 144 | unsafeByteIndex atom off = fromIntegral (unsafePerformIO $ peek (stPtr atom `advancePtr` off)) 145 | 146 | foreign import ccall unsafe "stringtable_lookup" addrToAtom_ :: Addr## -> Int## -> IO Atom 147 | 148 | foreign import ccall unsafe "stringtable_lookup" stAdd :: CString -> CInt -> IO Atom 149 | foreign import ccall unsafe "stringtable_ptr" stPtr :: Atom -> CString 150 | foreign import ccall unsafe "stringtable_stats" dumpStringTableStats :: IO () 151 | foreign import ccall unsafe "dump_table" dumpTable :: IO () 152 | foreign import ccall unsafe "atom_append" atomAppend :: Atom -> Atom -> IO Atom 153 | foreign import ccall unsafe "lexigraphic_compare" c_atomCompare :: Atom -> Atom -> CInt 154 | foreign import ccall unsafe "dump_to_file" dumpToFile :: IO () 155 | foreign import ccall unsafe hashlittle :: CString -> CSize -> Word32 -> IO Word32 156 | 157 | hash2 :: Word32 -> CString -> Int -> IO Word32 158 | hash2 init str size = hashlittle str (fromIntegral size) init 159 | 160 | atomCompare a b = if c == 0 then EQ else if c > 0 then GT else LT where 161 | c = c_atomCompare a b 162 | 163 | instance Intjection Atom where 164 | toIntjection i = Atom (fromIntegral i) 165 | fromIntjection (Atom i) = fromIntegral i 166 | 167 | newtype instance GSet Atom = GSetAtom (IntjectionSet Atom) 168 | deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike,Eq,Ord,Show) 169 | newtype instance GMap Atom v = GMapAtom (IntjectionMap Atom v) 170 | deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike,MapLike,Eq,Ord) 171 | 172 | instance Functor (GMap Atom) where 173 | fmap f (GMapAtom (IntjectionMap mp)) = GMapAtom (IntjectionMap (fmap f mp)) 174 | 175 | instance Binary Atom where 176 | get = do 177 | x <- getWord8 178 | bs <- getByteString (fromIntegral x) 179 | return $ toAtom bs 180 | put a = do 181 | let bs = fromAtom a 182 | putWord8 $ fromIntegral $ BS.length bs 183 | putByteString bs 184 | -------------------------------------------------------------------------------- /src/StringTable/StringTable_cbits.h: -------------------------------------------------------------------------------- 1 | #ifndef ST_CBITS_H 2 | #define ST_CBITS_H 3 | 4 | #include 5 | 6 | #define MAX_ENTRY_SIZE 256 7 | #define VALID_BITMASK 0x1 8 | 9 | // always shift, then mask 10 | #define ATOM_LEN_MASK 0xff 11 | #define ATOM_LEN_SHIFT 1 12 | 13 | typedef uint32_t atom_t; 14 | 15 | 16 | atom_t stringtable_lookup(unsigned char *cs, int len); 17 | void stringtable_stats(void); 18 | int stringtable_find(atom_t cl, unsigned char **res); 19 | unsigned char *stringtable_ptr(atom_t cl); 20 | 21 | 22 | #endif 23 | -------------------------------------------------------------------------------- /src/Support/CanType.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | module Support.CanType where 3 | 4 | -- This is a simple routine meant to do the minimum amount of work to get the type of something 5 | class CanType a where 6 | type TypeOf a 7 | getType :: a -> (TypeOf a) 8 | 9 | instance CanType e => CanType [e] where 10 | type TypeOf [e] = [TypeOf e] 11 | getType es = map getType es 12 | 13 | instance CanType e => CanType (Maybe e) where 14 | type TypeOf (Maybe e) = Maybe (TypeOf e) 15 | getType Nothing = Nothing 16 | getType (Just x) = Just (getType x) 17 | 18 | instance (CanType e1, CanType e2) => CanType (Either e1 e2) where 19 | type TypeOf (Either e1 e2) = Either (TypeOf e1) (TypeOf e2) 20 | getType (Left x) = Left $ getType x 21 | getType (Right x) = Right $ getType x 22 | -------------------------------------------------------------------------------- /src/Support/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -cpp #-} 2 | {-# LANGUAGE CPP #-} 3 | module Support.Compat where 4 | 5 | -- This module is meant to contain code 6 | -- that only exists for compatability between platforms 7 | 8 | import Control.Exception 9 | 10 | #if __GLASGOW_HASKELL__ < 610 11 | type SomeException' = Exception 12 | #else 13 | type SomeException' = SomeException 14 | #endif 15 | -------------------------------------------------------------------------------- /src/Support/FreeVars.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} 2 | module Support.FreeVars where 3 | 4 | import Data.Monoid 5 | 6 | class Monoid b => FreeVars a b where 7 | freeVars :: a -> b 8 | 9 | instance Monoid x => FreeVars () x where 10 | freeVars () = mempty 11 | 12 | instance (FreeVars x b, FreeVars y b) => FreeVars (x,y) b where 13 | freeVars (x,y) = freeVars x `mappend` freeVars y 14 | 15 | instance (FreeVars x b, FreeVars y b, FreeVars z b) => FreeVars (x,y,z) b where 16 | freeVars (x,y,z) = freeVars x `mappend` freeVars y `mappend` freeVars z 17 | 18 | instance FreeVars a b => FreeVars [a] b where 19 | freeVars as = mconcat (map freeVars as) 20 | 21 | instance FreeVars a b => FreeVars (Maybe a) b where 22 | freeVars (Just x) = freeVars x 23 | freeVars Nothing = mempty 24 | 25 | instance (FreeVars x b, FreeVars y b) => FreeVars (Either x y) b where 26 | freeVars (Left x) = freeVars x 27 | freeVars (Right y) = freeVars y 28 | -------------------------------------------------------------------------------- /src/Support/IniParse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Support.IniParse(parseIniFiles) where 3 | 4 | import Control.Monad.State 5 | import Data.Char 6 | import Data.List 7 | import GenUtil 8 | import qualified Data.Foldable as Seq 9 | import qualified Data.Map as Map 10 | import qualified Data.Sequence as Seq 11 | 12 | -- quick and dirty parser. 13 | 14 | type St = (Int,FilePath,String) 15 | 16 | newtype P a = P (State St a) 17 | deriving(Monad,MonadState St,Applicative,Functor) 18 | 19 | third (_,_,x) = x 20 | 21 | look :: P String 22 | look = gets third 23 | 24 | discard :: Int -> P () 25 | discard n = do 26 | (fl,fp,s) <- get 27 | let (x,y) = splitAt n s 28 | put (fl + length (filter (== '\n') x),fp, y) 29 | 30 | abort :: String -> P a 31 | abort msg = do 32 | (l,fp,_) <- get 33 | fail $ fp ++ ":" ++ show l ++ ": " ++ msg 34 | 35 | dropSpace = do 36 | x <- look 37 | case x of 38 | ';':_ -> pdropWhile ('\n' /=) >> dropSpace 39 | c:_ | isSpace c -> pdropWhile isSpace >> dropSpace 40 | _ -> return () 41 | 42 | pdropWhile f = do 43 | x <- look 44 | case x of 45 | c:_ | f c -> discard 1 >> pdropWhile f 46 | _ -> return () 47 | 48 | ptakeWhile f = do 49 | x <- look 50 | let ts = takeWhile f x 51 | discard (length ts) 52 | return ts 53 | 54 | pThings ch rs zs = ans where 55 | ans = look >>= \x -> case x of 56 | '[':_ -> do 57 | hv <- pHeader 58 | dropSpace 59 | pThings hv Seq.empty (zs Seq.|> (ch,rs)) 60 | _:_ -> do 61 | v <- pValue 62 | dropSpace 63 | pThings ch (rs Seq.|> v) zs 64 | [] -> return (zs Seq.|> (ch,rs)) 65 | 66 | trim = rbdropWhile isSpace 67 | 68 | expect w = do 69 | cs <- look 70 | if w `isPrefixOf` cs then discard (length w) else abort ("expected " ++ show w) 71 | 72 | pValue = do 73 | n <- ptakeWhile (`notElem` ['\n','=']) 74 | expect "=" 75 | rs <- ptakeWhile (/= '\n') 76 | return (trim n, trim rs) 77 | 78 | pHeader = do 79 | expect "[" 80 | n <- ptakeWhile (`notElem` "]\n") 81 | expect "]" 82 | return (trim n) 83 | 84 | -- We use laziness cleverly to avoid repeating work 85 | processIni :: Seq.Seq (String,Seq.Seq (String,String)) -> Map.Map String (Seq.Seq (String,String)) 86 | processIni iniRaw = iniMap' where 87 | iniMap,iniMap' :: Map.Map String (Seq.Seq (String,String)) 88 | iniMap = Map.fromListWith (flip (Seq.><)) (Seq.toList iniRaw) 89 | iniMap' = Map.map expandChains iniMap 90 | expandChains x = join (fmap ecp x) 91 | ecp :: (String,String) -> Seq.Seq (String,String) 92 | ecp ("merge",v) = Map.findWithDefault Seq.empty v iniMap' 93 | ecp x = Seq.singleton x 94 | -- ans = Map.map (\c -> Seq.foldl res Map.empty c) iniMap' 95 | -- res mp (k,v) | Just r <- getPrefix "+" (reverse k) = Map.insertWith f (reverse $ dropWhile isSpace r) v mp where 96 | -- f y x = x ++ " " ++ y 97 | -- res mp (k,v) = Map.insert k v mp 98 | 99 | parseIniFile :: FilePath -> IO (Seq.Seq (String,Seq.Seq (String,String))) 100 | parseIniFile fp = readFile fp >>= parseIniRaw fp 101 | 102 | parseIniRaw :: String -> String -> IO (Seq.Seq (String,Seq.Seq (String,String))) 103 | parseIniRaw fp c = do 104 | let P act = dropSpace >> pThings "default" Seq.empty Seq.empty 105 | return $ evalState act (0,fp,c) 106 | 107 | parseIniFiles 108 | :: Bool -- ^ whether verbose is enabled 109 | -> String -- ^ raw ini contents to parse first 110 | -> [FilePath] -- ^ the files (in order) we attempt to parse 111 | -> [String] -- ^ the m-flags 112 | -> IO (Map.Map String String) 113 | parseIniFiles verbose raw fs ss = do 114 | let rf fn = iocatch (do c <- parseIniFile fn; pverb ("reading " ++ fn); return c) (\_ -> return Seq.empty) 115 | pverb s = if verbose then putErrLn s else return () 116 | rawp <- parseIniRaw "(builtin targets.ini)" raw 117 | fsc <- mapM rf fs 118 | let pini = processIni (foldr (Seq.><) Seq.empty (rawp:fsc)) 119 | f (x:xs) cm = case span (/= '=') x of 120 | (be,'=':re) -> f xs (res cm (be,re)) -- f xs (Map.insert be re cm) 121 | ~(be,[]) -> f xs (Seq.foldl res cm (Map.findWithDefault Seq.empty be pini)) 122 | f [] cm = cm 123 | -- ans = Map.map (\c -> Seq.foldl res Map.empty c) iniMap' 124 | res mp (k,v) | Just r <- getPrefix "+" (reverse k) = Map.insertWith f (reverse $ dropWhile isSpace r) v mp where 125 | f y x = x ++ " " ++ y 126 | res mp (k,v) = Map.insert k v mp 127 | return (f ss Map.empty) 128 | 129 | --main = do 130 | -- as <- getArgs 131 | -- is <- mapM parseIniFile as 132 | -- let pi = processIni (foldr (Seq.><) Seq.empty is) 133 | -- 134 | -- print "proc" 135 | -- let f (h,rs) = do 136 | -- putStrLn h 137 | -- mapM_ (\x -> putStr " " >> print x) (Map.toList rs) 138 | -- mapM_ f (Map.toList pi) 139 | -------------------------------------------------------------------------------- /src/Support/TempDir.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface,ViewPatterns,RecordWildCards #-} 2 | -- Various routines for dealing with temporary directories and files. 3 | module Support.TempDir( 4 | getTempDir, 5 | createTempFile, 6 | fileInTempDir, 7 | cleanTempDir, 8 | setTempDir, 9 | addAtExit, 10 | withStackStatus, 11 | wrapMain 12 | ) where 13 | 14 | import Control.Exception as E 15 | import Control.Monad 16 | import Data.IORef 17 | import Data.List 18 | import Data.Maybe 19 | import Foreign.C 20 | import System.Directory 21 | import System.Exit 22 | import System.FilePath as FP 23 | import System.IO 24 | import System.IO.Unsafe 25 | import System.Posix.Signals 26 | import Text.Printf 27 | import qualified Data.Set as Set 28 | import GenUtil (iocatch) 29 | 30 | data TempDir = TempDir { 31 | tempDirClean :: Bool, -- ^ whether to delete the directory afterwords. 32 | tempDirDump :: Bool, 33 | tempDirPath :: Maybe String, 34 | tempDirAtExit :: [IO ()], 35 | tempDirCleanup :: Set.Set FilePath 36 | } 37 | 38 | putLog :: String -> IO () 39 | --putLog = putStrLn 40 | putLog _ = return () 41 | 42 | cleanTempDir :: Bool -> IO () 43 | cleanTempDir b = modifyIORef tdRef $ \x -> x { tempDirClean = b } 44 | 45 | setTempDir :: FilePath -> IO () 46 | setTempDir (FP.normalise -> fp) = do 47 | TempDir {..} <- readIORef tdRef 48 | when (isJust $ tempDirPath) $ do 49 | fail $ printf "Cannot set temp directory to '%s'; \ 50 | \it is already set to '%s'." fp (fromJust tempDirPath) 51 | putLog $ printf "Setting work directory to '%s'" fp 52 | createDirectoryIfMissing False fp 53 | writeIORef tdRef TempDir { tempDirPath = Just fp, .. } 54 | cleanTempDir False 55 | 56 | getTempDir :: IO FilePath 57 | getTempDir = do 58 | td <- readIORef tdRef 59 | case tempDirPath td of 60 | Just fp -> return fp 61 | Nothing -> do 62 | fp <- mkdtemp "/tmp/jhc_XXXXXX" 63 | putLog $ printf "Created work directory '%s'" fp 64 | writeIORef tdRef td { tempDirPath = Just fp } 65 | return fp 66 | 67 | addAtExit :: IO () -> IO () 68 | addAtExit action = do 69 | td <- readIORef tdRef 70 | writeIORef tdRef td { tempDirAtExit = action:tempDirAtExit td } 71 | 72 | createTempFile :: FilePath -> IO (FilePath, Handle) 73 | createTempFile (FP.normalise -> fp) = do 74 | unless (filePathSafe fp) $ 75 | fail $ "createTempFile: unsafe path " ++ fp 76 | dir <- getTempDir 77 | (fp,h) <- openBinaryTempFile dir (if null fp then "temp.tmp" else fp) 78 | putLog $ printf "Created temporary file '%s'" fp 79 | addCleanup fp 80 | return (fp,h) 81 | 82 | -- make sure nothing is sneaky about the file path 83 | filePathSafe fp = FP.isRelative fp && 84 | ".." `notElem` FP.splitPath fp && not (hasDrive fp) 85 | 86 | fileInTempDir :: FilePath -> (FilePath -> IO ()) -> IO FilePath 87 | fileInTempDir (FP.normalise -> fp) action = do 88 | unless (filePathSafe fp) $ 89 | fail $ "fileinTempDir: unsafe path " ++ fp 90 | let (FP.normalise -> dpart,_) = FP.splitFileName fp 91 | tdir <- getTempDir 92 | let f ("./":ps) cp = f ps cp 93 | f (".":ps) cp = f ps cp 94 | f (p:ps) cp = do 95 | putLog $ printf "Creating directory '%s' '%s' '%s' '%s' '%s'" tdir cp p dpart fp 96 | createDirectoryIfMissing False (tdir cp p) 97 | let cp' = FP.normalise (cp p) 98 | addCleanup cp' 99 | f ps cp' 100 | f [] _ = return () 101 | f (FP.splitPath dpart) "" 102 | --unless (null $ FP.normalise dpart) $ 103 | -- fold (FP.splitPath dpart) $ addCleanup 104 | -- createDirectoryIfMissing True (tdir dpart) 105 | let nfp = FP.normalise (tdir fp) 106 | b <- addCleanup fp 107 | when b $ action nfp 108 | return nfp 109 | 110 | cleanUp :: IO () 111 | cleanUp = do 112 | td <- readIORef tdRef 113 | sequence_ (tempDirAtExit td) 114 | if not (tempDirClean td) || 115 | isNothing (tempDirPath td) then return () else do 116 | dir <- getTempDir 117 | forM_ (reverse . Set.toList $ tempDirCleanup td) $ \fp -> do 118 | putLog $ printf "Removing '%s'" (dir fp) 119 | ignoreError (removeDirectory $ dir fp) 120 | ignoreError (removeFile $ dir fp) 121 | putLog $ printf "Removing '%s'" dir 122 | ignoreError (removeDirectory dir) 123 | 124 | addCleanup :: FilePath -> IO Bool 125 | addCleanup fp = do 126 | td <- readIORef tdRef 127 | if fp `Set.member` tempDirCleanup td then return False else do 128 | writeIORef tdRef td { tempDirCleanup = fp `Set.insert` tempDirCleanup td } 129 | return True 130 | 131 | wrapMain :: IO () -> IO () 132 | wrapMain main = E.catch (main >> cleanUp) f where 133 | f (fromException -> Just code) = cleanUp >> exitWith code 134 | f (fromException -> Just UserInterrupt) = cleanUp >> raiseSignal sigINT 135 | f e = do 136 | ss <- readIORef stackRef 137 | td <- readIORef tdRef 138 | case tempDirPath td of 139 | Just td -> hPutStrLn stderr $ 140 | printf "Exiting abnormally. Work directory is '%s'" td 141 | _ -> return () 142 | unless (null ss) $ 143 | forM_ ("Stack:":ss) (hPutStrLn stderr) 144 | throwIO e 145 | 146 | ------------------- 147 | -- support routines 148 | ------------------- 149 | 150 | ignoreError :: IO () -> IO () 151 | ignoreError action = iocatch action (\_ -> return ()) 152 | 153 | {-# NOINLINE tdRef #-} 154 | tdRef :: IORef TempDir 155 | tdRef = unsafePerformIO $ newIORef TempDir { 156 | tempDirClean = True, 157 | tempDirDump = False, 158 | tempDirPath = Nothing, 159 | tempDirAtExit = [], 160 | tempDirCleanup = Set.empty 161 | } 162 | 163 | foreign import ccall unsafe "stdlib.h mkdtemp" 164 | c_mkdtemp :: CString -> IO CString 165 | 166 | mkdtemp :: FilePath -> IO FilePath 167 | mkdtemp template = 168 | withCString (if "XXXXXX" `isSuffixOf` template then template 169 | else (template ++ "XXXXXX")) $ \ ptr -> do 170 | cname <- throwErrnoIfNull "mkdtemp" (c_mkdtemp ptr) 171 | peekCString cname 172 | 173 | {-# NOINLINE stackRef #-} 174 | stackRef :: IORef [String] 175 | stackRef = unsafePerformIO $ newIORef [] 176 | 177 | withStackStatus :: String -> IO a -> IO a 178 | withStackStatus s action = do 179 | cs <- readIORef stackRef 180 | writeIORef stackRef (s:cs) 181 | r <- action 182 | writeIORef stackRef cs 183 | return r 184 | -------------------------------------------------------------------------------- /src/Support/Tickle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | module Support.Tickle where 3 | 4 | import Control.Monad.Identity 5 | import Control.Monad.Writer 6 | 7 | class Tickleable a b where 8 | tickleM :: Monad m => (a -> m a) -> b -> m b 9 | tickleM_ :: Monad m => (a -> m c) -> b -> m () 10 | tickle :: (a -> a) -> b -> b 11 | 12 | tickle f x = runIdentity $ tickleM (return . f) x 13 | tickleM_ f b = tickleM (\x -> f x >> return x) b >> return () 14 | 15 | tickleCollect :: (Tickleable a b, Monoid o) => (a -> o) -> b -> o 16 | tickleCollect f b = execWriter (tickleM_ (tell . f) b) 17 | -------------------------------------------------------------------------------- /src/Support/Transform.hs: -------------------------------------------------------------------------------- 1 | module Support.Transform where 2 | 3 | data TransformParms p = TransformParms { 4 | transformIterate :: Iterate, 5 | transformDumpProgress :: Bool, 6 | transformSkipNoStats :: Bool, 7 | transformOperation :: p -> IO p, 8 | transformCategory :: String, -- ^ general name of transformation 9 | transformPass :: String, -- ^ what pass we are in 10 | transformName :: String -- ^ name of what we are working on 11 | } 12 | 13 | transformParms :: TransformParms p 14 | transformParms = TransformParms { 15 | transformIterate = DontIterate, 16 | transformDumpProgress = False, 17 | transformSkipNoStats = False, 18 | transformCategory = "Unknown", 19 | transformPass = "", 20 | transformOperation = return, 21 | transformName = "" 22 | } 23 | 24 | data Iterate = DontIterate | IterateMax !Int | IterateExactly !Int | IterateDone 25 | deriving(Eq) 26 | 27 | doIterate :: Iterate -> Bool -> Bool 28 | doIterate IterateMax {} True = True 29 | doIterate IterateDone True = True 30 | doIterate IterateExactly {} _ = True 31 | doIterate _ _ = False 32 | 33 | iterateStep :: Iterate -> Iterate 34 | iterateStep (IterateMax n) = IterateMax (n - 1) 35 | iterateStep (IterateExactly n) = IterateExactly (n - 1) 36 | iterateStep x = x 37 | -------------------------------------------------------------------------------- /src/Ty/Level.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving, DeriveFunctor, DeriveTraversable #-} 2 | module Ty.Level where 3 | 4 | import Util.Std 5 | 6 | newtype TyLevel = TyLevel Int 7 | deriving(Eq,Ord,Enum) 8 | 9 | -- inhabits constructor 10 | -- level(y) = level(x) + 1 11 | data x ::: y = x ::: y 12 | deriving(Eq,Ord,Functor,Traversable,Foldable,Show) 13 | 14 | instance Show TyLevel where 15 | showsPrec _ (TyLevel 0) = ('V':) 16 | showsPrec _ (TyLevel 1) = ('T':) 17 | showsPrec _ (TyLevel 2) = ('*':) 18 | showsPrec _ (TyLevel 3) = ('*':) . ('*':) 19 | showsPrec _ (TyLevel n) | n > 0 && n <= 10 = f (n - 3) where 20 | f 0 s = s 21 | f n s = '□':f (n - 1) s 22 | showsPrec _ (TyLevel n) = showString "(TyLevel:" . shows n . showChar ')' 23 | 24 | -- tyLevelOf is possibly not total 25 | class HasTyLevel a where 26 | getTyLevel :: a -> Maybe TyLevel 27 | tyLevelOf :: a -> TyLevel 28 | 29 | getTyLevel x = Just (tyLevelOf x) 30 | tyLevelOf x = case getTyLevel x of 31 | Just t -> t 32 | Nothing -> error "tyLevelOf: Does not have a TyLevel" 33 | 34 | instance HasTyLevel TyLevel where 35 | tyLevelOf t = t 36 | 37 | -- we subtract one from the level of the type as the 38 | -- term itself may not carry a level with it. 39 | instance HasTyLevel b => HasTyLevel (a ::: b) where 40 | getTyLevel (_ ::: y) = fmap pred (getTyLevel y) 41 | 42 | termLevel = TyLevel 0 43 | typeLevel = TyLevel 1 44 | kindLevel = TyLevel 2 45 | -------------------------------------------------------------------------------- /src/Util/ExitCodes.hs: -------------------------------------------------------------------------------- 1 | module Util.ExitCodes where 2 | 3 | import System.Exit 4 | 5 | -- The command was used incorrectly, e.g., with 6 | -- the wrong number of arguments, a bad flag, a bad 7 | -- syntax in a parameter, or whatever. 8 | exitCodeUsage = ExitFailure 64 9 | 10 | -- EX_DATAERR -- The input data was incorrect in some way. 11 | -- This should only be used for user's data & not 12 | -- system files. 13 | exitCodeDataError = ExitFailure 65 14 | 15 | -- EX_NOINPUT -- An input file (not a system file) did not 16 | -- exist or was not readable. This could also include 17 | -- errors like "No message" to a mailer (if it cared 18 | -- to catch it). 19 | exitCodeNoInput = ExitFailure 66 20 | 21 | -- EX_NOUSER -- The user specified did not exist. This might 22 | -- be used for mail addresses or remote logins. 23 | exitCodeNoUser = ExitFailure 67 24 | 25 | -- EX_NOHOST -- The host specified did not exist. This is used 26 | -- in mail addresses or network requests. 27 | exitCodeNoHost = ExitFailure 68 28 | 29 | -- EX_UNAVAILABLE -- A service is unavailable. This can occur 30 | -- if a support program or file does not exist. This 31 | -- can also be used as a catchall message when something 32 | -- you wanted to do doesn't work, but you don't know 33 | -- why. 34 | exitCodeUnavailable = ExitFailure 69 35 | 36 | -- EX_SOFTWARE -- An internal software error has been detected. 37 | -- This should be limited to non-operating system related 38 | -- errors as possible. 39 | exitCodeSoftware = ExitFailure 70 40 | 41 | -- EX_OSERR -- An operating system error has been detected. 42 | -- This is intended to be used for such things as "cannot 43 | -- fork", "cannot create pipe", or the like. It includes 44 | -- things like getuid returning a user that does not 45 | -- exist in the passwd file. 46 | exitCodeOSError = ExitFailure 71 47 | 48 | -- EX_OSFILE -- Some system file (e.g., /etc/passwd, /etc/utmp, 49 | -- etc.) does not exist, cannot be opened, or has some 50 | -- sort of error (e.g., syntax error). 51 | exitCodeOSFile = ExitFailure 72 52 | 53 | -- EX_CANTCREAT -- A (user specified) output file cannot be 54 | -- created. 55 | exitCodeCantCreate = ExitFailure 73 56 | 57 | -- EX_IOERR -- An error occurred while doing I/O on some file. 58 | exitCodeIOErr = ExitFailure 74 59 | 60 | -- EX_TEMPFAIL -- temporary failure, indicating something that 61 | -- is not really an error. In sendmail, this means 62 | -- that a mailer (e.g.) could not create a connection, 63 | -- and the request should be reattempted later. 64 | exitCodeTempFailure = ExitFailure 75 65 | 66 | -- EX_PROTOCOL -- the remote system returned something that 67 | -- was "not possible" during a protocol exchange. 68 | exitCodeProtocol = ExitFailure 76 69 | 70 | -- EX_NOPERM -- You did not have sufficient permission to 71 | -- perform the operation. This is not intended for 72 | -- file system problems, which should use NOINPUT or 73 | -- CANTCREAT, but rather for higher level permissions. 74 | exitCodeNoPerm = ExitFailure 77 75 | 76 | -- configuration error 77 | exitCodeConfig = ExitFailure 78 78 | 79 | -------------------------------------------------------------------------------- /src/Util/GMap.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -XTypeFamilies #-} 2 | {-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts #-} 3 | module Util.GMap where 4 | 5 | import Data.Monoid 6 | import Util.HasSize 7 | import Util.SetLike 8 | import qualified Data.IntMap as IM 9 | import qualified Data.IntSet as IS 10 | import qualified Data.Set as Set 11 | 12 | 13 | data family GMap k :: * -> * 14 | data family GSet k :: * 15 | 16 | newtype instance GMap Int v = GMapInt (IM.IntMap v) 17 | deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike,MapLike) 18 | newtype instance GSet Int = GSetInt IS.IntSet 19 | deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike) 20 | 21 | instance Functor (GMap Int) where 22 | fmap f (GMapInt v) = GMapInt $ fmap f v 23 | 24 | type instance Elem (GMap k v) = (k,v) 25 | type instance Key (GMap k v) = k 26 | type instance Value (GMap k v) = v 27 | type instance Elem (GSet k) = k 28 | type instance Key (GSet k) = k 29 | 30 | newtype instance GSet Char = GSetChar (EnumSet Char) 31 | deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike) 32 | newtype instance GMap Char v = GMapChar (EnumMap Char v) 33 | deriving(Monoid,IsEmpty,HasSize,Collection,Unionize,SetLike,MapLike) 34 | 35 | --newtype instance GSet (a,b) = GSetTup2 (GMap a (GSet b)) 36 | 37 | gsetToSet :: (Collection (GSet a), Ord a) => GSet a -> Set.Set a 38 | gsetToSet gs = Set.fromDistinctAscList (toList gs) 39 | 40 | class GMapSet k where 41 | toSet :: GMap k v -> GSet k 42 | toMap :: (k -> v) -> GSet k -> GMap k v 43 | 44 | instance GMapSet Int where 45 | toSet (GMapInt im) = GSetInt (IM.keysSet im) 46 | toMap f (GSetInt is) = GMapInt $ IM.fromDistinctAscList [ (x,f x) | x <- IS.toAscList is] 47 | -------------------------------------------------------------------------------- /src/Util/Gen.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | similar to GenUtil but can rely on non-haskell 98 features 3 | module Util.Gen(module Util.Gen, module GenUtil, intercalate) where 4 | 5 | import Control.Monad.Writer 6 | import Data.List 7 | import Data.Maybe 8 | import System.Directory 9 | import Text.ParserCombinators.ReadP 10 | 11 | import GenUtil hiding(replicateM, intercalate) 12 | 13 | mconcatMap f xs = mconcat (map f xs) 14 | mintercalate x xs = mconcat (intersperse x xs) 15 | 16 | mconcatMapM f xs = mapM f xs >>= return . mconcat 17 | 18 | runReadP :: Monad m => ReadP a -> String -> m a 19 | runReadP rp s = case [ x | (x,t) <- readP_to_S rp s, ("","") <- lex t] of 20 | [x] -> return x 21 | [] -> fail "runReadP: no parse" 22 | _ -> fail "runReadP: ambiguous parse" 23 | 24 | runEither :: String -> Either String a -> a 25 | runEither msg (Left fm) = error $ msg ++ " - " ++ fm 26 | runEither _ (Right a) = a 27 | 28 | travCollect :: Monoid w => ((a -> Writer w a) -> a -> Writer w a) -> (a -> w) -> a -> w 29 | travCollect fn col x = execWriter (f x) where 30 | f x = tell (col x) >> fn f x 31 | 32 | forMn_ xs = forM_ (zip xs [0 :: Int .. ]) 33 | forMn xs = forM (zip xs [0 :: Int .. ]) 34 | 35 | shortenPath :: String -> IO String 36 | shortenPath x@('/':_) = do 37 | cd <- getCurrentDirectory 38 | pwd <- lookupEnv' "PWD" 39 | h <- lookupEnv' "HOME" 40 | let f d = do 41 | d <- d 42 | '/':rest <- getPrefix d x 43 | return rest 44 | return $ fromJust $ f (return cd) `mplus` f pwd `mplus` liftM ("~/" ++) (f h) `mplus` return x 45 | shortenPath x = return x 46 | 47 | maybeDo :: Monad m => Maybe (m a) -> (m ()) 48 | maybeDo x = maybe (return ()) (>> return ()) x 49 | -------------------------------------------------------------------------------- /src/Util/Graph.hs: -------------------------------------------------------------------------------- 1 | -- | Data.Graph is sorely lacking in several ways, This just tries to fill in 2 | -- some holes and provide a more convinient interface 3 | {-# LANGUAGE RecursiveDo, RankNTypes, ScopedTypeVariables, FlexibleContexts #-} 4 | 5 | module Util.Graph( 6 | Graph(), 7 | fromGraph, 8 | newGraph, 9 | newGraph', 10 | newGraphReachable, 11 | reachableFrom, 12 | Util.Graph.reachable, 13 | fromScc, 14 | findLoopBreakers, 15 | sccGroups, 16 | Util.Graph.scc, 17 | sccForest, 18 | Util.Graph.dff, 19 | Util.Graph.components, 20 | Util.Graph.topSort, 21 | cyclicNodes, 22 | toDag, 23 | restitchGraph, 24 | mapGraph, 25 | transitiveClosure, 26 | transitiveReduction 27 | ) where 28 | 29 | import Control.Monad 30 | import Control.Monad.ST 31 | import Data.Array.IArray 32 | import Data.Array.ST hiding(unsafeFreeze) 33 | import Data.Array.Unsafe (unsafeFreeze) 34 | import Data.Graph hiding(Graph) 35 | import Data.Maybe 36 | import GenUtil 37 | import Data.List(sort,sortBy,group,delete) 38 | import qualified Data.Graph as G 39 | import qualified Data.Map as Map 40 | 41 | data Graph n = Graph G.Graph (Table n) 42 | 43 | instance Show n => Show (Graph n) where 44 | showsPrec n g = showsPrec n (Util.Graph.scc g) 45 | 46 | fromGraph :: Graph n -> [(n,[n])] 47 | fromGraph (Graph g lv) = [ (lv!v,map (lv!) vs) | (v,vs) <- assocs g ] 48 | 49 | newGraph :: Ord k => [n] -> (n -> k) -> (n -> [k]) -> (Graph n) 50 | newGraph ns a b = snd $ newGraph' ns a b 51 | 52 | newGraphReachable :: Ord k => [n] -> (n -> k) -> (n -> [k]) -> ([k] -> [n],Graph n) 53 | newGraphReachable ns fn fd = (rable,ng) where 54 | (vmap,ng) = newGraph' ns fn fd 55 | rable ks = Util.Graph.reachable ng [ v | Just v <- map (flip Map.lookup vmap) ks ] 56 | 57 | reachableFrom :: Ord k => (n -> k) -> (n -> [k]) -> [n] -> [k] -> [n] 58 | reachableFrom fn fd ns = fst $ newGraphReachable ns fn fd 59 | 60 | -- | Build a graph from a list of nodes uniquely identified by keys, 61 | -- with a list of keys of nodes this node should have edges to. 62 | -- The out-list may contain keys that don't correspond to 63 | -- nodes of the graph; they are ignored. 64 | newGraph' :: Ord k => [n] -> (n -> k) -> (n -> [k]) -> (Map.Map k Vertex,Graph n) 65 | newGraph' ns fn fd = (kmap,Graph graph nr) where 66 | nr = listArray bounds0 ns 67 | max_v = length ns - 1 68 | bounds0 = (0,max_v) :: (Vertex, Vertex) 69 | kmap = Map.fromList [ (fn n,i) | (i,n) <- zip [0 ..] ns ] 70 | graph = listArray bounds0 [mapMaybe (flip Map.lookup kmap) (snub $ fd n) | n <- ns] 71 | 72 | fromScc (Left n) = [n] 73 | fromScc (Right n) = n 74 | 75 | -- | determine a set of loopbreakers subject to a fitness function 76 | -- loopbreakers have a minimum of their incoming edges ignored. 77 | findLoopBreakers 78 | :: (n -> Int) -- ^ fitness function, greater numbers mean more likely to be a loopbreaker 79 | -> (n -> Bool) -- ^ whether a node is suitable at all for a choice as loopbreaker 80 | -> Graph n -- ^ the graph 81 | -> ([n],[n]) -- ^ (loop breakers,dependency ordered nodes after loopbreaking) 82 | findLoopBreakers func ex (Graph g ln) = ans where 83 | scc = G.scc g 84 | ans = f g scc [] [] where 85 | f g (Node v []:sccs) fs lb 86 | | v `elem` g ! v = let ng = (fmap (delete v) g) in f ng (G.scc ng) [] (v:lb) 87 | | otherwise = f g sccs (v:fs) lb 88 | 89 | f g (n:_) fs lb = f ng (G.scc ng) [] (mv:lb) where 90 | mv = case sortBy (\ a b -> compare (snd b) (snd a)) [ (v,func (ln!v)) | v <- ns, ex (ln!v) ] of 91 | ((mv,_):_) -> mv 92 | [] -> error "findLoopBreakers: no valid loopbreakers" 93 | ns = dec n [] 94 | ng = fmap (delete mv) g 95 | 96 | f _ [] xs lb = (map ((ln!) . head) (group $ sort lb),reverse $ map (ln!) xs) 97 | dec (Node v ts) vs = v:foldr dec vs ts 98 | 99 | reachable :: Graph n -> [Vertex] -> [n] 100 | reachable (Graph g ln) vs = map (ln!) $ snub $ concatMap (G.reachable g) vs 101 | 102 | sccGroups :: Graph n -> [[n]] 103 | sccGroups g = map fromScc (Util.Graph.scc g) 104 | 105 | scc :: Graph n -> [Either n [n]] 106 | scc (Graph g ln) = map decode forest where 107 | forest = G.scc g 108 | decode (Node v []) 109 | | v `elem` g ! v = Right [ln!v] 110 | | otherwise = Left (ln!v) 111 | decode other = Right (dec other []) 112 | dec (Node v ts) vs = ln!v:foldr dec vs ts 113 | 114 | sccForest :: Graph n -> Forest n 115 | sccForest (Graph g ln) = map (fmap (ln!)) forest where 116 | forest = G.scc g 117 | 118 | dff :: Graph n -> Forest n 119 | dff (Graph g ln) = map (fmap (ln!)) forest where 120 | forest = G.dff g 121 | 122 | components :: Graph n -> [[n]] 123 | components (Graph g ln) = map decode forest where 124 | forest = G.components g 125 | decode n = dec n [] 126 | dec (Node v ts) vs = ln!v:foldr dec vs ts 127 | 128 | topSort :: Graph n -> [n] 129 | topSort (Graph g ln) = map (ln!) $ G.topSort g 130 | 131 | cyclicNodes :: Graph n -> [n] 132 | cyclicNodes g = concat [ xs | Right xs <- Util.Graph.scc g] 133 | 134 | toDag :: Graph n -> Graph [n] 135 | toDag (Graph g lv) = Graph g' ns' where 136 | ns' = listArray (0,max_v) [ map (lv!) ns | ns <- nss ] 137 | g' = listArray (0,max_v) [ snub [ v | n <- ns, v <- g!n ] | ns <- nss ] 138 | max_v = length nss - 1 139 | nss = map (flip f []) (G.scc g) where 140 | f (Node v ts) rs = v:foldr f rs ts 141 | 142 | type AdjacencyMatrix s = STArray s (Vertex,Vertex) Bool 143 | type IAdjacencyMatrix = Array (Vertex,Vertex) Bool 144 | 145 | transitiveClosureAM :: AdjacencyMatrix s -> ST s () 146 | transitiveClosureAM arr = do 147 | bnds@(_,(max_v,_)) <- getBounds arr 148 | forM_ [0 .. max_v] $ \k -> do 149 | forM_ (range bnds) $ \ (i,j) -> do 150 | dij <- readArray arr (i,j) 151 | dik <- readArray arr (i,k) 152 | dkj <- readArray arr (k,j) 153 | writeArray arr (i,j) (dij || (dik && dkj)) 154 | 155 | transitiveReductionAM :: AdjacencyMatrix s -> ST s () 156 | transitiveReductionAM arr = do 157 | bnds@(_,(max_v,_)) <- getBounds arr 158 | transitiveClosureAM arr 159 | (farr :: IAdjacencyMatrix) <- freeze arr 160 | forM_ [0 .. max_v] $ \k -> do 161 | forM_ (range bnds) $ \ (i,j) -> do 162 | if farr!(k,i) && farr!(i,j) then 163 | writeArray arr (k,j) False 164 | else return () 165 | 166 | toAdjacencyMatrix :: G.Graph -> ST s (AdjacencyMatrix s) 167 | toAdjacencyMatrix g = do 168 | let (0,max_v) = bounds g 169 | arr <- newArray ((0,0),(max_v,max_v)) False :: ST s (STArray s (Vertex,Vertex) Bool) 170 | sequence_ [ writeArray arr (v,u) True | (v,vs) <- assocs g, u <- vs ] 171 | return arr 172 | 173 | fromAdjacencyMatrix :: AdjacencyMatrix s -> ST s G.Graph 174 | fromAdjacencyMatrix arr = do 175 | bnds@(_,(max_v,_)) <- getBounds arr 176 | rs <- getAssocs arr 177 | let rs' = [ x | (x,True) <- rs ] 178 | return (listArray (0,max_v) [ [ v | (n',v) <- rs', n == n' ] | n <- [ 0 .. max_v] ]) 179 | 180 | transitiveClosure :: Graph n -> Graph n 181 | transitiveClosure (Graph g ns) = let g' = runST (tc g) in (Graph g' ns) where 182 | tc g = do 183 | a <- toAdjacencyMatrix g 184 | transitiveClosureAM a 185 | fromAdjacencyMatrix a 186 | 187 | transitiveReduction :: Graph n -> Graph n 188 | transitiveReduction (Graph g ns) = let g' = runST (tc g) in (Graph g' ns) where 189 | tc g = do 190 | a <- toAdjacencyMatrix g 191 | transitiveReductionAM a 192 | fromAdjacencyMatrix a 193 | 194 | instance Functor Graph where 195 | fmap f (Graph g n) = Graph g (fmap f n) 196 | 197 | --mapT :: (Vertex -> a -> b) -> Table a -> Table b 198 | --mapT f t = listArray (bounds t) [ (f v (t!v)) | v <- indices t ] 199 | 200 | restitchGraph :: Ord k => (n -> k) -> (n -> [k]) -> Graph n -> Graph n 201 | restitchGraph fn fd (Graph g nr) = Graph g' nr where 202 | kmap = Map.fromList [ (fn n,i) | (i,n) <- assocs nr ] 203 | g' = listArray (bounds g) [mapMaybe (flip Map.lookup kmap) (snub $ fd n) | n <- elems nr] 204 | 205 | mapGraph :: forall a b . (a -> [b] -> b) -> Graph a -> Graph b 206 | mapGraph f (Graph gr nr) = runST $ do 207 | mnr <- thaw nr :: ST s (STArray s Vertex a) 208 | mnr <- mapArray Left mnr 209 | let g i = readArray mnr i >>= \v -> case v of 210 | Right m -> return m 211 | Left l -> mdo 212 | writeArray mnr i (Right r) 213 | rs <- mapM g (gr!i) 214 | let r = f l rs 215 | return r 216 | mapM_ g (range $ bounds nr) 217 | mnr <- mapArray fromRight mnr 218 | mnr <- unsafeFreeze mnr 219 | return (Graph gr mnr) 220 | -------------------------------------------------------------------------------- /src/Util/Graphviz.hs: -------------------------------------------------------------------------------- 1 | -- | Simple graphviz output. 2 | module Util.Graphviz( 3 | Orient(..), 4 | graphviz, graphviz' 5 | ) where 6 | 7 | import Data.Graph.Inductive.Graph 8 | import Data.List(intersperse) 9 | 10 | data Orient = Portrait | Landscape deriving (Eq, Show) 11 | 12 | {- 13 | o2s :: Orient -> String 14 | o2s Portrait = "\trotate = \"0\"\n" 15 | o2s Landscape = "\trotate = \"90\"\n" 16 | 17 | i2d :: Int -> Double 18 | i2d = fromInteger . toInteger 19 | -} 20 | 21 | 22 | -- | Format a graph for graphviz with reasonable defaults: title of \"fgl\", 23 | -- 8.5x11 pages, one page, landscape orientation 24 | graphviz' :: Graph g => g a b -> [(String,String)] -> (a -> [(String,String)]) -> (b -> [(String,String)]) -> String 25 | graphviz' g headers fnode fedge = graphviz g "fgl" headers fnode fedge (8.5,11.0) (1,1) Landscape 26 | 27 | sq :: String -> String 28 | sq ('"':s) | last s == '"' = init s 29 | | otherwise = s 30 | sq ('\'':s) | last s == '\'' = init s 31 | | otherwise = s 32 | sq s = s 33 | 34 | 35 | sl :: [(String,String)] -> String 36 | sl [] = [] 37 | sl a = " [" ++ foldr ($) "]" (intersperse (',':) (map showEq a)) where 38 | 39 | showEq :: (String,String) -> String -> String 40 | showEq (x,y) = ((x ++ " = " ++ (show y)) ++) 41 | 42 | 43 | 44 | graphviz :: Graph g => g a b -- ^ The graph to format 45 | -> String -- ^ The title of the graph 46 | -> [(String,String)] 47 | -> (a -> [(String,String)]) 48 | -> (b -> [(String,String)]) 49 | -> (Double, Double) -- ^ The size 50 | -- of the page 51 | -> (Int, Int) -- ^ The width and 52 | -- height of the page 53 | -- grid 54 | -> Orient -- ^ The orientation of 55 | -- the graph. 56 | -> String 57 | 58 | 59 | graphviz g t headers fnode fedge (w, h) p@(pw', ph') o = 60 | let n = labNodes g 61 | e = labEdges g 62 | ns = concatMap sn n 63 | es = concatMap se e 64 | --sz w' h' = if o == Portrait then show w'++","++show h' else show h'++","++show w' 65 | --ps = show w++","++show h 66 | --(pw, ph) = if o == Portrait then p else (ph', pw') 67 | --gs = show ((w*(i2d pw))-m)++","++show ((h*(i2d ph))-m) 68 | --gs = sz (w*(i2d pw)) (h*(i2d ph)) 69 | in "digraph "++sq t++" {\n" 70 | -- ++"\tmargin = \"0\"\n" 71 | -- ++"\tpage = \""++ps++"\"\n" 72 | -- ++"\tsize = \""++gs++"\"\n" 73 | ++ concatMap (\x -> showEq x "\n") headers 74 | -- ++ o2s o 75 | -- ++"\tratio = \"fill\"\n" 76 | ++ns 77 | ++es 78 | ++"}" 79 | where sn (n, a) | sa == "" = "" 80 | | otherwise = '\t':(show n ++ sa ++ "\n") 81 | where sa = sl (fnode a) 82 | se (n1, n2, b) = '\t':(show n1 ++ " -> " ++ show n2 ++ sl (fedge b) ++ "\n") 83 | 84 | 85 | 86 | -------------------------------------------------------------------------------- /src/Util/HasSize.hs: -------------------------------------------------------------------------------- 1 | module Util.HasSize where 2 | 3 | -- this point of this module is not only to share the 'size' syntax, but to 4 | -- provide optimally lazy versions of size comparasin functions when dealing 5 | -- with lazy structures. This is especially useful when having to compare the 6 | -- size of possibly long lists. 7 | 8 | -- it is up to each instance to decide what 'size' means 9 | 10 | import qualified Data.Map(Map,size,null) 11 | import qualified Data.Set(Set,size,null) 12 | import qualified Data.IntMap(IntMap,size,null) 13 | import qualified Data.IntSet(IntSet,size,null) 14 | 15 | 16 | class IsEmpty a where 17 | isEmpty :: a -> Bool 18 | 19 | class HasSize a where 20 | size :: a -> Int 21 | sizeEQ :: Int -> a -> Bool 22 | sizeGT :: Int -> a -> Bool 23 | sizeLT :: Int -> a -> Bool 24 | sizeGTE :: Int -> a -> Bool 25 | sizeLTE :: Int -> a -> Bool 26 | sizeEQ s x = size x == s 27 | sizeGT s x = size x > s 28 | sizeLT s x = size x < s 29 | sizeGTE s x = not $ sizeLT s x 30 | sizeLTE s x = not $ sizeGT s x 31 | 32 | genSize :: (Integral b,HasSize a) => a -> b 33 | genSize = fromIntegral . Util.HasSize.size 34 | 35 | instance HasSize [x] where 36 | size = length 37 | sizeEQ n _ | n < 0 = False 38 | sizeEQ n xs = f n xs where 39 | f 0 [] = True 40 | f _ [] = False 41 | f 0 _ = False 42 | f n (_:xs) = sizeEQ (n - 1) xs 43 | sizeGT n _ | n < 0 = True 44 | sizeGT n xs = f n xs where 45 | f 0 (_:_) = True 46 | f n [] = False 47 | f n (_:xs) = f (n - 1) xs 48 | sizeLT n _ | n <= 0 = False 49 | sizeLT n xs = f n xs where 50 | f 0 _ = False 51 | f _ [] = True 52 | f n (_:xs) = f (n - 1) xs 53 | 54 | 55 | instance HasSize (Data.Map.Map a b) where 56 | size = Data.Map.size 57 | instance HasSize (Data.Set.Set a) where 58 | size = Data.Set.size 59 | instance HasSize (Data.IntMap.IntMap v) where 60 | size = Data.IntMap.size 61 | instance HasSize Data.IntSet.IntSet where 62 | size = Data.IntSet.size 63 | 64 | instance (HasSize a,HasSize b) => HasSize (Either a b) where 65 | size (Left x) = size x 66 | size (Right y) = size y 67 | sizeEQ s (Left x) = sizeEQ s x 68 | sizeEQ s (Right x) = sizeEQ s x 69 | sizeLT s (Left x) = sizeLT s x 70 | sizeLT s (Right x) = sizeLT s x 71 | sizeGT s (Left x) = sizeGT s x 72 | sizeGT s (Right x) = sizeGT s x 73 | 74 | instance (HasSize a,HasSize b) => HasSize (a,b) where 75 | size (x,y) = size x + size y 76 | instance (HasSize a,HasSize b,HasSize c) => HasSize (a,b,c) where 77 | size (x,y,z) = size x + size y + size z 78 | 79 | instance IsEmpty [x] where 80 | isEmpty = null 81 | 82 | instance IsEmpty (Data.Map.Map a b) where 83 | isEmpty = Data.Map.null 84 | instance IsEmpty (Data.Set.Set a) where 85 | isEmpty = Data.Set.null 86 | instance IsEmpty (Data.IntMap.IntMap v) where 87 | isEmpty = Data.IntMap.null 88 | instance IsEmpty Data.IntSet.IntSet where 89 | isEmpty = Data.IntSet.null 90 | 91 | instance (IsEmpty a,IsEmpty b) => IsEmpty (a,b) where 92 | isEmpty (x,y) = isEmpty x && isEmpty y 93 | instance (IsEmpty a,IsEmpty b,IsEmpty c) => IsEmpty (a,b,c) where 94 | isEmpty (x,y,z) = isEmpty x && isEmpty y && isEmpty z 95 | 96 | 97 | -------------------------------------------------------------------------------- /src/Util/Once.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | a simple type that only lets an IO action happen once, caching its result. 3 | 4 | module Util.Once( 5 | Once, 6 | newOnce, 7 | runOnce, 8 | altOnce, 9 | 10 | OnceMap, 11 | newOnceMap, 12 | runOnceMap, 13 | altOnceMap, 14 | onceMapToList, 15 | onceMapKeys, 16 | onceMapElems 17 | 18 | ) where 19 | 20 | import qualified Data.Map as Map 21 | import Data.IORef 22 | import Data.Dynamic 23 | 24 | newtype Once a = Once (IORef (Maybe a)) 25 | deriving(Typeable) 26 | 27 | 28 | -- | create a new Once object 29 | newOnce :: IO (Once a) 30 | newOnce = do 31 | ref <- newIORef Nothing 32 | return (Once ref) 33 | 34 | -- | execute the action at most once, always returning the same result 35 | runOnce :: Once a -> IO a -> IO a 36 | runOnce (Once ref) action = do 37 | b <- readIORef ref 38 | case b of 39 | Just x -> return x 40 | Nothing -> do 41 | r <- action 42 | writeIORef ref (Just r) 43 | return r 44 | 45 | -- | run first argument once, after which perform the second 46 | 47 | altOnce :: Once () -> IO b -> IO b -> IO b 48 | altOnce (Once ref) first second = do 49 | b <- readIORef ref 50 | case b of 51 | Just _ -> second 52 | Nothing -> do 53 | writeIORef ref (Just ()) 54 | first 55 | 56 | 57 | -- | run an IO action at most once for each distinct argument 58 | 59 | newtype OnceMap a b = OnceMap (IORef (Map.Map a b)) 60 | deriving(Typeable) 61 | 62 | 63 | newOnceMap :: Ord a => IO (OnceMap a b) 64 | newOnceMap = do 65 | r <- newIORef Map.empty 66 | return $ OnceMap r 67 | 68 | runOnceMap :: Ord a => OnceMap a b -> a -> IO b -> IO b 69 | runOnceMap (OnceMap r) x act = do 70 | m <- readIORef r 71 | case Map.lookup x m of 72 | Just y -> return y 73 | Nothing -> do 74 | y <- act 75 | modifyIORef r (Map.insert x y) 76 | return y 77 | 78 | altOnceMap :: Ord a => OnceMap a () -> a -> IO b -> IO b -> IO b 79 | altOnceMap (OnceMap ref) x first after = do 80 | m <- readIORef ref 81 | case Map.member x m of 82 | True -> after 83 | False -> do 84 | modifyIORef ref (Map.insert x ()) 85 | first 86 | 87 | onceMapToList :: OnceMap a b -> IO [(a,b)] 88 | onceMapToList (OnceMap ref) = do 89 | m <- readIORef ref 90 | return $ Map.toList m 91 | 92 | onceMapKeys :: OnceMap a b -> IO [a] 93 | onceMapKeys (OnceMap ref) = do 94 | m <- readIORef ref 95 | return $ Map.keys m 96 | 97 | onceMapElems :: OnceMap a b -> IO [b] 98 | onceMapElems (OnceMap ref) = do 99 | m <- readIORef ref 100 | return $ Map.elems m 101 | 102 | -------------------------------------------------------------------------------- /src/Util/Perhaps.hs: -------------------------------------------------------------------------------- 1 | module Util.Perhaps where 2 | 3 | import Data.Binary 4 | import GHC.Generics (Generic) 5 | 6 | import Data.Typeable 7 | import Data.Monoid 8 | 9 | data Perhaps = No | Maybe | Yes 10 | deriving(Show,Read,Typeable,Eq,Ord,Generic) 11 | 12 | instance Binary Perhaps 13 | 14 | -- the greatest lower bound was chosen as the Monoid 15 | -- the least upper bound is just the maximum under Ord 16 | instance Monoid Perhaps where 17 | mempty = No 18 | Yes `mappend` Yes = Yes 19 | No `mappend` No = No 20 | _ `mappend` _ = Maybe 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /src/Util/SetLike.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -XTypeFamilies #-} 2 | {-# LANGUAGE ViewPatterns, GeneralizedNewtypeDeriving, DeriveTraversable #-} 3 | module Util.SetLike where 4 | 5 | import Data.List(foldl') 6 | import Data.Monoid 7 | import qualified Data.Map as M 8 | import qualified Data.IntMap as IM 9 | import qualified Data.Set as S 10 | import qualified Data.IntSet as IS 11 | import Util.HasSize 12 | import Data.Foldable hiding(toList, foldl') 13 | import Data.Traversable 14 | 15 | infixl 9 \\ -- 16 | 17 | (\\) :: Unionize s => s -> s -> s 18 | m1 \\ m2 = difference m1 m2 19 | 20 | class Monoid s => Unionize s where 21 | union :: s -> s -> s 22 | difference :: s -> s -> s 23 | intersection :: s -> s -> s 24 | unions :: [s] -> s 25 | sempty :: s 26 | 27 | sempty = mempty 28 | union = mappend 29 | unions = foldl' union mempty 30 | 31 | type family Elem es :: * 32 | type family Key s :: * 33 | type family Value m :: * 34 | 35 | class Monoid s => Collection s where 36 | fromList :: [Elem s] -> s 37 | fromDistinctAscList :: [Elem s] -> s 38 | toList :: s -> [Elem s] 39 | singleton :: Elem s -> s 40 | singleton e = fromList [e] 41 | 42 | fromDistinctAscList = fromList 43 | 44 | class Collection s => SetLike s where 45 | keys :: s -> [Key s] 46 | member :: Key s -> s -> Bool 47 | delete :: Key s -> s -> s 48 | sfilter :: (Elem s -> Bool) -> s -> s 49 | insert :: Elem s -> s -> s 50 | spartition :: (Elem s -> Bool) -> s -> (s,s) 51 | 52 | notMember :: SetLike s => Key s -> s -> Bool 53 | notMember k s = not $ member k s 54 | 55 | class SetLike m => MapLike m where 56 | mlookup :: Key m -> m -> Maybe (Value m) 57 | values :: m -> [Value m] 58 | unionWith :: (Value m -> Value m -> Value m) -> m -> m -> m 59 | 60 | instance Unionize IS.IntSet where 61 | union = IS.union 62 | difference = IS.difference 63 | intersection = IS.intersection 64 | 65 | type instance Elem IS.IntSet = Int 66 | 67 | instance Collection IS.IntSet where 68 | fromList = IS.fromList 69 | toList = IS.toList 70 | singleton = IS.singleton 71 | fromDistinctAscList = IS.fromDistinctAscList 72 | 73 | type instance Key IS.IntSet = Int 74 | instance SetLike IS.IntSet where 75 | keys = IS.toList 76 | member = IS.member 77 | sfilter = IS.filter 78 | delete = IS.delete 79 | insert = IS.insert 80 | spartition = IS.partition 81 | 82 | instance Ord k => Unionize (S.Set k) where 83 | union = S.union 84 | intersection = S.intersection 85 | difference = S.difference 86 | 87 | type instance Elem (S.Set k) = k 88 | instance Ord k => Collection (S.Set k) where 89 | fromList = S.fromList 90 | toList = S.toList 91 | singleton = S.singleton 92 | fromDistinctAscList = S.fromDistinctAscList 93 | 94 | type instance Key (S.Set k) = k 95 | instance Ord k => SetLike (S.Set k) where 96 | keys = S.toList 97 | member = S.member 98 | sfilter = S.filter 99 | delete = S.delete 100 | insert = S.insert 101 | spartition = S.partition 102 | 103 | instance Unionize (IM.IntMap v) where 104 | union = IM.union 105 | difference = IM.difference 106 | intersection = IM.intersection 107 | 108 | type instance Elem (IM.IntMap v) = (Int,v) 109 | instance Collection (IM.IntMap v) where 110 | fromList = IM.fromList 111 | toList = IM.toList 112 | singleton (k,v) = IM.singleton k v 113 | fromDistinctAscList = IM.fromDistinctAscList 114 | 115 | type instance Key (IM.IntMap v) = Int 116 | instance SetLike (IM.IntMap v) where 117 | keys = IM.keys 118 | member = IM.member 119 | sfilter f = IM.filterWithKey (\ k v -> f (k,v)) 120 | delete = IM.delete 121 | insert (k,v) = IM.insert k v 122 | spartition f = IM.partitionWithKey (\ k v -> f (k,v)) 123 | 124 | type instance Value (IM.IntMap v) = v 125 | instance MapLike (IM.IntMap v) where 126 | mlookup = IM.lookup 127 | values = IM.elems 128 | unionWith = IM.unionWith 129 | 130 | instance Ord k => Unionize (M.Map k v) where 131 | union = M.union 132 | difference = M.difference 133 | intersection = M.intersection 134 | 135 | type instance Elem (M.Map k v) = (k,v) 136 | instance Ord k => Collection (M.Map k v) where 137 | fromList = M.fromList 138 | toList = M.toList 139 | singleton (k,v) = M.singleton k v 140 | fromDistinctAscList = M.fromDistinctAscList 141 | 142 | type instance Key (M.Map k v) = k 143 | instance Ord k => SetLike (M.Map k v) where 144 | keys = M.keys 145 | member = M.member 146 | sfilter f = M.filterWithKey (\ k v -> f (k,v)) 147 | delete = M.delete 148 | insert (k,v) = M.insert k v 149 | spartition f = M.partitionWithKey (\ k v -> f (k,v)) 150 | 151 | type instance Value (M.Map k v) = v 152 | instance Ord k => MapLike (M.Map k v) where 153 | mlookup = M.lookup 154 | values = M.elems 155 | unionWith = M.unionWith 156 | 157 | minsert :: (MapLike m, Elem m ~ (k,v)) => k -> v -> m -> m 158 | minsert k v = insert (k,v) 159 | 160 | msingleton :: (MapLike m, Elem m ~ (k,v)) => k -> v -> m 161 | msingleton k v = singleton (k,v) 162 | 163 | intersects x y = not $ isEmpty (x `intersection` y) 164 | 165 | findWithDefault :: MapLike m => Value m -> Key m -> m -> Value m 166 | findWithDefault d k m = case mlookup k m of 167 | Nothing -> d 168 | Just x -> x 169 | 170 | newtype EnumSet a = EnumSet IS.IntSet 171 | deriving(Monoid,IsEmpty,HasSize,Unionize,Eq,Ord) 172 | 173 | type instance Elem (EnumSet a) = a 174 | type instance Key (EnumSet a) = a 175 | 176 | instance Enum a => Collection (EnumSet a) where 177 | singleton i = EnumSet $ singleton (fromEnum i) 178 | fromList ts = EnumSet $ fromList (map fromEnum ts) 179 | toList (EnumSet w) = map toEnum $ toList w 180 | 181 | instance Enum a => SetLike (EnumSet a) where 182 | keys = toList 183 | delete (fromEnum -> i) (EnumSet v) = EnumSet $ delete i v 184 | member (fromEnum -> i) (EnumSet v) = member i v 185 | insert (fromEnum -> i) (EnumSet v) = EnumSet $ insert i v 186 | sfilter f (EnumSet v) = EnumSet $ sfilter (f . toEnum) v 187 | spartition f (EnumSet v) = case spartition (f . toEnum) v of 188 | (x,y) -> (EnumSet x,EnumSet y) 189 | 190 | newtype EnumMap k v = EnumMap (IM.IntMap v) 191 | deriving(Monoid,IsEmpty,Functor,Foldable,Traversable,HasSize,Unionize,Eq,Ord) 192 | 193 | type instance Elem (EnumMap k v) = (k,v) 194 | type instance Key (EnumMap k v) = k 195 | type instance Value (EnumMap k v) = v 196 | 197 | instance Enum k => Collection (EnumMap k v) where 198 | singleton (k,v) = EnumMap $ singleton (fromEnum k,v) 199 | fromList ts = EnumMap $ fromList [ (fromEnum k,v) | (k,v) <- ts ] 200 | toList (EnumMap kv) = [ (toEnum k,v) | (k,v) <- toList kv] 201 | 202 | instance Enum k => SetLike (EnumMap k v) where 203 | keys (EnumMap v) = map toEnum $ keys v 204 | delete (fromEnum -> i) (EnumMap v) = EnumMap $ delete i v 205 | member (fromEnum -> i) (EnumMap v) = member i v 206 | insert (fromEnum -> k,v) (EnumMap m) = EnumMap $ insert (k,v) m 207 | sfilter f (EnumMap v) = EnumMap $ sfilter (\ (k,v) -> f (toEnum k,v)) v 208 | spartition f (EnumMap v) = case spartition (\ (k,v) -> f (toEnum k,v)) v of 209 | (x,y) -> (EnumMap x,EnumMap y) 210 | 211 | instance Enum k => MapLike (EnumMap k v) where 212 | mlookup (fromEnum -> i) (EnumMap v) = mlookup i v 213 | values (EnumMap v) = values v 214 | unionWith f (EnumMap x) (EnumMap y) = EnumMap $ unionWith f x y 215 | 216 | -- must be an injection into the integers 217 | class Intjection a where 218 | fromIntjection :: a -> Int 219 | toIntjection :: Int -> a 220 | 221 | newtype IntjectionSet a = IntjectionSet IS.IntSet 222 | deriving(Monoid,IsEmpty,HasSize,Unionize,Eq,Ord) 223 | 224 | instance (Intjection a,Show a) => Show (IntjectionSet a) where 225 | showsPrec n is = showsPrec n $ toList is 226 | 227 | type instance Elem (IntjectionSet a) = a 228 | type instance Key (IntjectionSet a) = a 229 | 230 | instance Intjection a => Collection (IntjectionSet a) where 231 | singleton i = IntjectionSet $ singleton (fromIntjection i) 232 | fromList ts = IntjectionSet $ fromList (map fromIntjection ts) 233 | toList (IntjectionSet w) = map toIntjection $ toList w 234 | 235 | instance Intjection a => SetLike (IntjectionSet a) where 236 | keys = toList 237 | delete (fromIntjection -> i) (IntjectionSet v) = IntjectionSet $ delete i v 238 | member (fromIntjection -> i) (IntjectionSet v) = member i v 239 | insert (fromIntjection -> i) (IntjectionSet v) = IntjectionSet $ insert i v 240 | sfilter f (IntjectionSet v) = IntjectionSet $ sfilter (f . toIntjection) v 241 | spartition f (IntjectionSet v) = case spartition (f . toIntjection) v of 242 | (x,y) -> (IntjectionSet x,IntjectionSet y) 243 | 244 | newtype IntjectionMap k v = IntjectionMap (IM.IntMap v) 245 | deriving(Monoid,IsEmpty,Functor,Foldable,Traversable,HasSize,Unionize,Eq,Ord) 246 | 247 | type instance Elem (IntjectionMap k v) = (k,v) 248 | type instance Key (IntjectionMap k v) = k 249 | type instance Value (IntjectionMap k v) = v 250 | 251 | instance Intjection k => Collection (IntjectionMap k v) where 252 | singleton (k,v) = IntjectionMap $ singleton (fromIntjection k,v) 253 | fromList ts = IntjectionMap $ fromList [ (fromIntjection k,v) | (k,v) <- ts ] 254 | toList (IntjectionMap kv) = [ (toIntjection k,v) | (k,v) <- toList kv] 255 | 256 | instance Intjection k => SetLike (IntjectionMap k v) where 257 | keys (IntjectionMap v) = map toIntjection $ keys v 258 | delete (fromIntjection -> i) (IntjectionMap v) = IntjectionMap $ delete i v 259 | member (fromIntjection -> i) (IntjectionMap v) = member i v 260 | insert (fromIntjection -> k,v) (IntjectionMap m) = IntjectionMap $ insert (k,v) m 261 | sfilter f (IntjectionMap v) = IntjectionMap $ sfilter (\ (k,v) -> f (toIntjection k,v)) v 262 | spartition f (IntjectionMap v) = case spartition (\ (k,v) -> f (toIntjection k,v)) v of 263 | (x,y) -> (IntjectionMap x,IntjectionMap y) 264 | 265 | instance Intjection k => MapLike (IntjectionMap k v) where 266 | mlookup (fromIntjection -> i) (IntjectionMap v) = mlookup i v 267 | values (IntjectionMap v) = values v 268 | unionWith f (IntjectionMap x) (IntjectionMap y) = IntjectionMap $ unionWith f x y 269 | 270 | -------------------------------------------------------------------------------- /src/Util/Std.hs: -------------------------------------------------------------------------------- 1 | -- standard modules we almost always want 2 | module Util.Std( 3 | module Control.Applicative, 4 | module Control.Monad, 5 | module Control.Monad.Identity, 6 | module Data.Foldable, 7 | module Data.List, 8 | module Data.Maybe, 9 | module Data.Monoid, 10 | module Data.Traversable, 11 | module System.Environment 12 | )where 13 | 14 | import Control.Applicative 15 | import Control.Monad 16 | import Control.Monad.Identity 17 | import Data.List hiding(null) 18 | import Data.Maybe 19 | import Data.Monoid(Monoid(..),(<>)) 20 | import System.Environment(getArgs,getProgName) 21 | -- we want the names for deriving 22 | import Data.Traversable(Traversable()) 23 | import Data.Foldable(Foldable()) 24 | -------------------------------------------------------------------------------- /src/Util/UnionFind.hs: -------------------------------------------------------------------------------- 1 | module Util.UnionFind( 2 | Element, 3 | T, 4 | find, 5 | fromElement, 6 | getW, 7 | new, 8 | new_, 9 | putW, 10 | union, 11 | union_, 12 | updateW 13 | ) where 14 | 15 | import Control.Monad.Trans 16 | import Data.IORef 17 | import Data.Unique 18 | import Control.Monad (when) 19 | 20 | data Element w a = Element a !Unique {-# UNPACK #-} !(IORef (Link w a)) 21 | data Link w a = Weight {-# UNPACK #-} !Int w | Next (Element w a) 22 | 23 | type T = Element 24 | 25 | new :: MonadIO m => w -> a -> m (Element w a) 26 | new w x = liftIO $ do 27 | r <- newIORef (Weight 1 w) 28 | n <- newUnique 29 | return $ Element x n r 30 | 31 | new_ :: MonadIO m => a -> m (Element () a) 32 | new_ x = new () x 33 | 34 | find :: MonadIO m => Element w a -> m (Element w a) 35 | find x@(Element a _ r) = liftIO $ do 36 | e <- readIORef r 37 | case e of 38 | Weight _ _ -> return x 39 | Next next -> do 40 | last <- Util.UnionFind.find next 41 | when (next /= last) $ writeIORef r (Next last) 42 | return last 43 | 44 | getW :: MonadIO m => Element w a -> m w 45 | getW x = liftIO $ do 46 | Element _ _ r <- find x 47 | Weight _ w <- readIORef r 48 | return w 49 | 50 | updateW :: MonadIO m => (w -> w) -> Element w a -> m () 51 | updateW f x = liftIO $ do 52 | Element _ _ r <- find x 53 | modifyIORef r (\ (Weight s w) -> Weight s (f w)) 54 | 55 | putW :: MonadIO m => Element w a -> w -> m () 56 | putW e w = liftIO $ do 57 | Element _ _ r <- find e 58 | modifyIORef r (\ (Weight s _) -> Weight s w) 59 | 60 | union :: MonadIO m => (w -> w -> w) -> Element w a -> Element w a -> m () 61 | union comb e1 e2 = liftIO $ do 62 | e1'@(Element _ _ r1) <- find e1 63 | e2'@(Element _ _ r2) <- find e2 64 | when (r1 /= r2) $ do 65 | Weight w1 x1 <- readIORef r1 66 | Weight w2 x2 <- readIORef r2 67 | if w1 <= w2 then do 68 | writeIORef r1 (Next e2') 69 | writeIORef r2 $! (Weight (w1 + w2) (comb x1 x2)) 70 | else do 71 | writeIORef r1 $! (Weight (w1 + w2) (comb x1 x2)) 72 | writeIORef r2 (Next e1') 73 | 74 | union_ :: MonadIO m => Element () a -> Element () a -> m () 75 | union_ x y = union (\_ _ -> ()) x y 76 | 77 | fromElement :: Element w a -> a 78 | fromElement (Element a _ _) = a 79 | 80 | instance Eq (Element w a) where 81 | Element _ x _ == Element _ y _ = x == y 82 | Element _ x _ /= Element _ y _ = x /= y 83 | 84 | instance Ord (Element w a) where 85 | Element _ x _ `compare` Element _ y _ = x `compare` y 86 | Element _ x _ <= Element _ y _ = x <= y 87 | Element _ x _ >= Element _ y _ = x >= y 88 | 89 | instance Show a => Show (Element w a) where 90 | showsPrec n (Element x _ _) = showsPrec n x 91 | -------------------------------------------------------------------------------- /src/Util/UniqueMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, UndecidableInstances, GeneralizedNewtypeDeriving, OverlappingInstances #-} 2 | module Util.UniqueMonad(UniqT,Uniq, runUniq, runUniqT, execUniq1, execUniq, execUniqT, UniqueProducer(..)) where 3 | 4 | import Control.Applicative 5 | import Control.Monad.Identity 6 | import Control.Monad.Reader 7 | import Control.Monad.State 8 | import Data.Unique 9 | import GenUtil 10 | 11 | instance UniqueProducer IO where 12 | newUniq = do 13 | u <- newUnique 14 | return $ hashUnique u 15 | 16 | instance Monad m => UniqueProducer (UniqT m) where 17 | newUniq = UniqT $ do 18 | modify (+1) 19 | get 20 | 21 | -- | Run the transformer version of the unique int generator. 22 | runUniqT :: Monad m => UniqT m a -> Int -> m (a,Int) 23 | runUniqT (UniqT sm) s = runStateT sm s 24 | 25 | -- | Run the bare version of the unique int generator. 26 | runUniq :: Int -> Uniq a -> (a,Int) 27 | runUniq x y = runIdentity $ runUniqT y x 28 | 29 | -- | Execute the bare unique int generator starting with 1. 30 | execUniq1 :: Uniq a -> a 31 | execUniq1 x = fst $ runUniq 1 x 32 | 33 | -- | Execute the bare unique int generator starting with the suplied number. 34 | execUniq :: Int -> Uniq a -> a 35 | execUniq st x = fst $ runUniq st x 36 | 37 | -- | Execute the transformer version of the unique int generator starting with the suplied number. 38 | execUniqT :: Monad m => Int -> UniqT m a -> m a 39 | execUniqT s (UniqT sm) = liftM fst $ runStateT sm s 40 | 41 | instance (Monad m, Monad (t m), MonadTrans t, UniqueProducer m) => UniqueProducer (t m) where 42 | newUniq = lift newUniq 43 | 44 | -- | Unique integer generator monad transformer. 45 | newtype UniqT m a = UniqT (StateT Int m a) 46 | deriving(Monad, Applicative, MonadTrans, Functor, MonadFix, MonadPlus, Alternative) 47 | 48 | instance MonadReader s m => MonadReader s (UniqT m) where 49 | ask = UniqT $ ask 50 | local f (UniqT x) = UniqT $ local f x 51 | 52 | -- | Unique integer generator monad. 53 | type Uniq = UniqT Identity 54 | -------------------------------------------------------------------------------- /src/Util/YAML.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverlappingInstances, TypeSynonymInstances, FlexibleInstances #-} 2 | module Util.YAML where 3 | 4 | import Data.Char 5 | import qualified Data.Map as M 6 | import qualified Data.Set as S 7 | 8 | data Node = Leaf String | List [Node] | Map [(String,Node)] | Null 9 | 10 | class MapKey a where 11 | showMapKey :: a -> String 12 | 13 | instance MapKey String where 14 | showMapKey s = s 15 | 16 | class ToNode a where 17 | toNode :: a -> Node 18 | 19 | instance ToNode Node where 20 | toNode x = x 21 | 22 | instance ToNode String where 23 | toNode s = Leaf s 24 | 25 | instance ToNode a => ToNode [a] where 26 | toNode ns = List (map toNode ns) 27 | 28 | instance (MapKey k,ToNode a) => ToNode [(k,a)] where 29 | toNode ns = Map [ (showMapKey x,toNode y) | (x,y) <- ns ] 30 | 31 | instance (MapKey k,ToNode b) => ToNode (M.Map k b) where 32 | toNode mp = Map [(showMapKey x, toNode y) | (x,y) <- M.toList mp] 33 | 34 | instance ToNode a => ToNode (S.Set a) where 35 | toNode st = List $ map toNode (S.toList st) 36 | 37 | instance ToNode a => ToNode (Maybe a) where 38 | toNode Nothing = Null 39 | toNode (Just x) = toNode x 40 | 41 | instance (ToNode a,ToNode b) => ToNode (Either a b) where 42 | toNode (Left x) = toNode x 43 | toNode (Right x) = toNode x 44 | 45 | instance ToNode Bool where 46 | toNode True = Leaf "true" 47 | toNode False = Leaf "false" 48 | 49 | instance ToNode () where 50 | toNode () = Null 51 | 52 | dumpNode :: Node -> String 53 | dumpNode n = f False 0 n "\n" where 54 | f nn i Null = ns nn . showString "null" 55 | f nn i (Leaf x) = ns nn . showString' x 56 | f nn i (List ns) = nl nn [ g i . showString "-" . f True (i + 1) n | n <- ns ] 57 | f nn i (Map ns) = nl nn [ g i . showString x . showString ":" . f True (i + 1) y | (x,y) <- ns ] 58 | g i = showString $ replicate i ' ' 59 | nl nn [] = id 60 | nl nn xs = (if nn then ('\n':) else id) . foldr1 (\x y -> x . showChar '\n' . y ) xs 61 | ns True = showChar ' ' 62 | ns False = id 63 | 64 | showYAML :: ToNode a => a -> String 65 | showYAML n = dumpNode (toNode n) 66 | 67 | showString' x y = if all isGood x then x ++ y else '"':f x y where 68 | f [] y = '"':y 69 | f (x:xs) ys | isQuoteGood x = x:f xs ys 70 | | otherwise = '\\':x:f xs ys 71 | isGood x = isAlphaNum x || x `elem` "_-.@/" 72 | isQuoteGood x = isGood x || isSpace x || x `elem` "!@#$%^&*(){}/" 73 | -------------------------------------------------------------------------------- /src/Version/Config.hs: -------------------------------------------------------------------------------- 1 | module Version.Config where 2 | 3 | shortVersion = "0.8" 4 | version = "0.8.2" 5 | package = "jhc" 6 | libdir = "/usr/local/lib" 7 | datadir = "/usr/local/share" 8 | host = "x86_64-unknown-linux-gnu" 9 | libraryInstall = "/usr/local/share/jhc-0.8" 10 | confDir = "/usr/local/etc/jhc-0.8" 11 | 12 | ho_version, version_major, version_minor, version_patch :: Int 13 | ho_version = 14 14 | version_major = 0 15 | version_minor = 8 16 | version_patch = 2 17 | revision = show $ (version_major*100 + version_minor :: Int)*100 + version_patch 18 | -------------------------------------------------------------------------------- /src/Version/Config.hs.in: -------------------------------------------------------------------------------- 1 | module Version.Config where 2 | 3 | shortVersion = "@SHORTVERSION@" 4 | version = "@VERSION@" 5 | package = "@PACKAGE@" 6 | libdir = "@LIBDIR@" 7 | datadir = "@DATADIR@" 8 | host = "@host@" 9 | libraryInstall = "@JLIBPATH@" 10 | confDir = "@JETCPATH@" 11 | 12 | ho_version, version_major, version_minor, version_patch :: Int 13 | ho_version = @HO_VERSION@ 14 | version_major = @VERSION_MAJOR@ 15 | version_minor = @VERSION_MINOR@ 16 | version_patch = @VERSION_PATCH@ 17 | revision = show $ (version_major*100 + version_minor :: Int)*100 + version_patch 18 | -------------------------------------------------------------------------------- /src/Version/Version.hs: -------------------------------------------------------------------------------- 1 | module Version.Version( 2 | versionContext, 3 | versionSimple, 4 | versionString 5 | ) where 6 | 7 | 8 | import Data.Version 9 | import System.Info 10 | import qualified Data.ByteString.UTF8 as BS 11 | 12 | import Version.Config 13 | import RawFiles 14 | 15 | {-# NOINLINE versionSimple #-} 16 | versionSimple = concat [package, " ", version, " (", BS.toString shortchange_txt, ")"] 17 | 18 | {-# NOINLINE versionString #-} 19 | versionString = concat [versionSimple, "\n", "compiled by ",compilerName,"-",showVersion compilerVersion," on a ",arch," running ",os] 20 | 21 | {-# NOINLINE versionContext #-} 22 | versionContext = changelog 23 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.0 2 | flags: {} 3 | packages: 4 | - '.' 5 | extra-deps: [] 6 | --------------------------------------------------------------------------------