New patches: [start adding new primitive decoder John Meacham **20120126224847 Ignore-this: 94c7101d2e1e30c47749c747f3e4fc55 ] hunk ./Makefile.am 39 src/Util/Relation.hs src/Util/RWS.hs src/Util/SameShape.hs src/Util/Seq.hs src/Util/SetLike.hs src/Util/UnionFind.hs \ src/Util/UnionSolve.hs src/Util/UniqueMonad.hs src/Util/Util.hs src/Util/VarName.hs src/Version/Config.hs src/Version/Version.hs \ src/Support/IniParse.hs src/E/Lint.hs src/Util/Progress.hs src/Grin/StorageAnalysis.hs src/Util/YAML.hs src/Grin/Main.hs \ - src/E/Main.hs src/Util/GMap.hs src/Util/ExitCodes.hs src/Support/TempDir.hs + src/E/Main.hs src/Util/GMap.hs src/Util/ExitCodes.hs src/Support/TempDir.hs src/E/PrimDecode.hs GHCDEBUGOPTS= -W -fno-warn-unused-matches -fwarn-type-defaults GHCPROFOPTS= -prof -auto-all -osuf prof.o -hisuf prof.hi hunk ./src/Cmm/Op.hs 91 | FLte -- whether two values can be compared at all. | FOrdered - deriving(Eq,Show,Ord,Read) + deriving(Eq,Show,Ord,Read,Enum,Bounded) {-! derive: Binary !-} data UnOp hunk ./src/Cmm/Op.hs 112 | Log | Exp | Sqrt - deriving(Eq,Show,Ord,Read) + deriving(Eq,Show,Ord,Read,Enum,Bounded) {-! derive: Binary !-} -- conversion ops hunk ./src/Cmm/Op.hs 129 | I2I -- ^ perform a 'Lobits' or a 'Sx' depending on the sizes of the arguments | U2U -- ^ perform a 'Lobits' or a 'Zx' depending on the sizes of the arguments | B2B -- ^ a nop, useful for coercing hints (bits 2 bits) - deriving(Eq,Show,Ord,Read) + deriving(Eq,Show,Ord,Read,Enum,Bounded) {-! derive: Binary !-} data ValOp hunk ./src/Cmm/Op.hs 138 | NInf | PZero | NZero - deriving(Eq,Show,Ord,Read) + deriving(Eq,Show,Ord,Read,Bounded) {-! derive: Binary !-} data ArchBits = BitsMax | BitsPtr | BitsUnknown hunk ./src/E/FromHs.hs 26 import E.E import E.Eta import E.Eval(eval) +import E.PrimDecode import E.LetFloat(atomizeAp) import E.PrimOpt import E.Rules hunk ./src/E/FromHs.hs 295 let e2 = atomizeAp mempty False dataTable e2' return (hsRuleIsMeta pr,hsRuleString pr,( snds (cs' ++ ts) ),eval $ smt $ sma e1,e2) -convertE :: Monad m => TiData -> ClassHierarchy -> Map.Map Name Type -> DataTable -> SrcLoc -> HsExp -> m E +convertE :: MonadWarn m => TiData -> ClassHierarchy -> Map.Map Name Type + -> DataTable -> SrcLoc -> HsExp -> m E convertE tiData classHierarchy assumps dataTable srcLoc exp = do hunk ./src/E/FromHs.hs 298 - [(_,_,e)] <- convertDecls tiData mempty classHierarchy assumps dataTable [HsPatBind srcLoc (HsPVar v_silly) (HsUnGuardedRhs exp) []] + [(_,_,e)] <- convertDecls tiData mempty classHierarchy assumps dataTable + [HsPatBind srcLoc (HsPVar v_silly) (HsUnGuardedRhs exp) []] return e v_silly = toName Val ("Jhc@","silly") hunk ./src/E/FromHs.hs 349 return (eLam y fgy) {-# NOINLINE convertDecls #-} -convertDecls :: Monad m => TiData -> IdMap Properties -> ClassHierarchy -> Map.Map Name Type -> DataTable -> [HsDecl] -> m [(Name,TVr,E)] -convertDecls tiData props classHierarchy assumps dataTable hsDecls = liftM fst $ evalRWST ans ceEnv 2 where +convertDecls :: MonadWarn m => TiData -> IdMap Properties + -> ClassHierarchy -> Map.Map Name Type -> DataTable + -> [HsDecl] -> m [(Name,TVr,E)] +convertDecls tiData props classHierarchy assumps dataTable hsDecls = res where + res = do + (a,ws) <- evalRWST ans ceEnv 2 + mapM_ addWarning ws + return a ceEnv = CeEnv { ceCoerce = tiCoerce tiData, ceAssumps = assumps, hunk ./src/E/FromHs.hs 450 (eJustIO (EVar tvrWorld2) (EVar rtVar)) cDecl :: Monad m => HsDecl -> Ce m [(Name,TVr,E)] - cDecl (HsForeignDecl _ (FfiSpec (Import cn req) _ Primitive) n _) = do + cDecl (HsForeignDecl sLoc (FfiSpec (Import cn req) _ Primitive) n _) = do let name = toName Name.Val n (var,ty,lamt) <- convertValue name let (ts,rt) = argTypes' ty hunk ./src/E/FromHs.hs 454 - prim = APrim (PrimPrim $ toAtom cn) req +-- prim = APrim (PrimPrim $ toAtom cn) req es <- newVars [ t | t <- ts, not (sortKindLike t) ] hunk ./src/E/FromHs.hs 456 - let result = foldr ($) (processPrimPrim dataTable $ EPrim prim [ EVar e | e <- es, not (tvrType e == tUnit)] rt) (map ELam es) - return [(name,setProperty prop_INLINE var,lamt result)] + --let result = foldr ($) (processPrimPrim dataTable $ EPrim prim [ EVar e | e <- es, not (tvrType e == tUnit)] rt) (map ELam es) + --result <- return (processPrimPrim dataTable $ EPrim prim [ EVar e | e <- es, not (tvrType e == tUnit)] rt) + result <- processPrim dataTable sLoc (toAtom cn) + [ EVar e | e <- es, not (tvrType e == tUnit)] rt req + return [(name,setProperty prop_INLINE var, + lamt $ foldr ($) result (map ELam es))] cDecl (HsForeignDecl _ (FfiSpec (ImportAddr rcn req) _ _) n _) = do let name = toName Name.Val n (var,ty,lamt) <- convertValue name hunk ./src/E/Main.hs 35 import FrontEnd.HsSyn import FrontEnd.KindInfer import FrontEnd.Tc.Module +import FrontEnd.Warning import Grin.Show(render) import Ho.Build import Ho.Collected hunk ./src/E/Main.hs 299 wdump FD.Stats $ Stats.printLStat (optStatLevel options) "MainPass Stats" (progStats prog) + processIOErrors + lintCheckProgram (putErrLn "After the workwrap/CPR") prog prog <- programPrune prog addfile ./src/E/PrimDecode.hs hunk ./src/E/PrimDecode.hs 1 +{-# LANGUAGE OverloadedStrings #-} +-- translate foreign Prim statements to jhc core +module E.PrimDecode(processPrim) where + +import Text.Printf + +import C.Prims +import Cmm.Op(readTy,Ty) +import DataConstructors +import E.E +import E.Values +import FrontEnd.SrcLoc +import FrontEnd.Tc.Kind +import FrontEnd.Warning +import StringTable.Atom +import Support.CanType +import qualified Cmm.Op as Op +import qualified Data.Map as Map + +{- +-- type to describe type patterns, used for error checking types. +data Var t = Var !Int t +data Quant = Forall | Exists +data Ty t + = Quant Quant [Var t] t + | Kind KBase + | V (Var t) + | t :-> t + | Or [t] + | t :*> t + | C Name + | A (Ty t) [Ty t] + +match :: Fix Ty -> + +-- a :*> b = a :*> (a :-> b) | b + +-- describes a pattern the type of a prim must match +data TSpec + = K KBase + | TSpec :-> TSpec + | TSpec :*> TSpec -- repeated + | UIO_ + | UIO TSpec + | TA [TSpec] +-} + +data Typ = [KBase] :-> KBase + deriving (Show) + +--data BType +-- = BVar !Int KBase +-- | BCon Name (Maybe [BType]) + +star = [] :-> Star +hash = [] :-> KHash +starHash = [] :-> KQuestQuest +world = hash + +infixr 3 +> +[] :-> k +> ks :-> rt = (k:ks) :-> rt + +infix 1 ==> +a ==> b = (a,b) +--plainPrimMap, rawArgPrimMap, prefixPrimMap :: Map.Map Atom Typ +plainPrimMap, fullPlainPrimMap :: Map.Map Atom Typ +plainPrimMap = Map.fromList + [ "seq" ==> star +> starHash +> starHash + , "dependingOn" ==> star +> starHash +> star + , "newWorld__" ==> star +> world + , "zero" ==> star + , "one" ==> star + , "box" ==> hash +> star + , "unbox" ==> star +> hash + , "increment" ==> starHash +> starHash + , "decrement" ==> starHash +> starHash + , "fincrement" ==> starHash +> starHash + , "fdecrement" ==> starHash +> starHash + , "constPeekByte" ==> hash +> hash + , "exitFailure__" ==> hash +> hash + ] +ashow op = toAtom (show op) +fullPlainPrimMap = Map.union plainPrimMap . Map.fromList + $ [ (ashow op ==> starHash +> starHash +> starHash) + | op :: Op.BinOp <- [minBound .. maxBound] ] + ++ [ (ashow op ==> starHash +> starHash) + | op :: Op.UnOp <- [minBound .. maxBound] ] + ++ [ (ashow op ==> starHash +> starHash) + | op :: Op.ConvOp <- [minBound .. maxBound] ] +--rawArgPrimMap = +-- [ "peek." ==> starHash :-> UIO starHash +-- , "poke." ==> starHash :-> UIO starHash +-- ] +--prefixPrimMap = rawArgPrimMap ++ +-- [ "const." ==> TA [star,hash :-> hash] +-- , "error." ==> star +-- ] + +-- | A safe version of 'zipWith'. +pairWith :: (a -> b -> c) + -> [a] -> [b] -> Maybe [c] +pairWith f xs ys = g xs ys [] where + g [] [] rs = Just $ reverse rs + g (x:xs) (y:ys) rs = g xs ys (f x y:rs) + g _ _ _ = Nothing + +processPrim :: MonadWarn m + => DataTable + -> SrcLoc -- ^ location of declaration + -> Atom -- ^ primitive name + -> [E] -- ^ arguments + -> E -- ^ return type + -> Requires -- ^ c requires + -> m E -- ^ result +processPrim dT srcLoc pName args rType req = ans where + ans = case Map.lookup pName fullPlainPrimMap of + Just typ -> checkType typ (return passThrough) + Nothing -> prefixOp + checkType (tas :-> trt) onFail = + case pairWith match tas (map (getType . getType) args) of + Just cs | and cs, match trt (getType rType) -> looksGood + _ -> do + warn srcLoc "primitive-badtype" $ + printf "Primitive type mismatch. expected '%s' but found '%s -> %s'" + (show (tas :-> trt)) (show $ map (getType . getType) args) (show $ getType rType) + onFail + prefixOp = return passThrough + looksGood = return passThrough + passThrough = EPrim (APrim (PrimPrim pName) req) args rType + + match k e = f k where + f Star = e == eStar + f KHash = e == eHash + f KQuestQuest = e == eStar || e == eHash + f _ = False + +{- +processPrimPrim :: DataTable -> E -> E +processPrimPrim dataTable o@(EPrim (APrim (PrimPrim s) _) es orig_t) = maybe o id (primopt (fromAtom s) es (followAliases dataTable orig_t)) where + primBoundMap = [("maxBound",PrimMaxBound), ("minBound",PrimMinBound), ("umaxBound",PrimUMaxBound)] + primopt "seq" [x,y] _ = return $ prim_seq x y + primopt "exitFailure__" [w] rt = return $ EError "" rt + primopt op [a,b] t | Just cop <- readM op = mdo + (pa,(ta,_sta)) <- extractPrimitive dataTable a + (pb,(tb,_stb)) <- extractPrimitive dataTable b + (bp,(tr,str)) <- boxPrimitive dataTable + (EPrim (APrim Op { primCOp = Op.BinOp cop (stot cop 1 ta) (stot cop 2 tb), primRetTy = (stot cop 0 tr) } mempty) [pa, pb] str) t + return bp + primopt op [a] t | Just cop <- readM op = mdo + (pa,(ta,_sta)) <- extractPrimitive dataTable a + (bp,(tr,str)) <- boxPrimitive dataTable + (EPrim (APrim Op { primCOp = Op.UnOp cop (stringToOpTy ta), primRetTy = (stringToOpTy tr) } mempty) [pa] str) t + return bp + primopt op [a] t | Just cop <- readM op = mdo + (pa,(ta,_sta)) <- extractPrimitive dataTable a + (bp,(tr,str)) <- boxPrimitive dataTable + (EPrim (APrim Op { primCOp = Op.ConvOp cop (stringToOpTy ta), primRetTy = (stringToOpTy tr) } mempty) [pa] str) t + return bp + primopt "constPeekByte" [a] t = return (EPrim (APrim (Peek Op.bits8) mempty) [a] t) + primopt "box" [a] t = return ans where + (ExtTypeBoxed cna _ _) = fromMaybe (error $ "lookupExtTypeInfo(box): " ++ show t) $ lookupExtTypeInfo dataTable t + ans = ELit litCons { litName = cna, litArgs = [a], litType = orig_t } + primopt "unbox" [a] t = return ans where + (vara:_) = newIds (freeVars (a,t,orig_t)) + ans = unbox dataTable a vara $ \tvra -> EVar tvra + primopt op [a] t | Just o <- lookup op unop = do + (pa,(ta,sta)) <- extractPrimitive dataTable a + let tvra = tVr vn sta; (vn:_) = newIds (freeVars (a,t)) + (bp,(tr,str)) <- boxPrimitive dataTable (EVar tvra) t + let res = EPrim (APrim (Op (Op.BinOp o (stringToOpTy ta) (stringToOpTy ta)) (stringToOpTy tr)) mempty) [pa, ELit (LitInt 1 sta)] str + return $ eStrictLet tvra res bp + where unop = [("increment",Op.Add),("decrement",Op.Sub),("fincrement",Op.FAdd),("fdecrement",Op.FSub)] + primopt n [] t | Just num <- lookup n vs = mdo + (res,(_,sta)) <- boxPrimitive dataTable (ELit (LitInt num sta)) t; return res + where vs = [("zero",0),("one",1)] + primopt "options_target" [] t = return (ELit (LitInt 0 t)) + primopt pn@(flip lookup primBoundMap -> Just c) [] t = return $ ans where + Just tt = Op.readTy $ show rtn + (ExtTypeBoxed cna rt _) = fromMaybe (error $ "lookupExtTypeInfo(box): " ++ show t) $ lookupExtTypeInfo dataTable t + ELit LitCons { litName = rtn } = rt + ee = (EPrim (APrim (PrimTypeInfo tt tt c) mempty) [] rt) + ans = ELit litCons { litName = cna, litArgs = [ee], litType = orig_t } + primopt pn [] t | Just c <- getPrefix "options_" pn = return (EPrim (APrim (CConst ("JHC_" ++ c) "int") mempty) [] t) + primopt pn [a,w] t | Just c <- getPrefix "peek." pn >>= Op.readTy = return (EPrim (APrim (Peek c) mempty) [w,a] t) + --primopt pn [a,w] t | Just c <- getPrefix "peek." pn >>= Op.readTy = + -- boxResult dataTable t $ \_ pt -> (EPrim (APrim (Peek c) mempty) [w,a] pt) + primopt pn [a,v,w] t | Just c <- getPrefix "poke." pn >>= Op.readTy = return (EPrim (APrim (Poke c) mempty) [w,a,v] t) + primopt pn [v] t | Just c <- getPrefix "sizeOf." pn >>= Op.readTy = return (EPrim (APrim (PrimTypeInfo c Op.bits32 PrimSizeOf) mempty) [] t) + primopt pn [v] t | Just c <- getPrefix "alignmentOf." pn >>= Op.readTy = return (EPrim (APrim (PrimTypeInfo c Op.bits32 PrimAlignmentOf) mempty) [] t) + primopt pn [v] t | Just c <- getPrefix "maxBound." pn >>= Op.readTy = return (EPrim (APrim (PrimTypeInfo c c PrimMaxBound) mempty) [] t) + primopt pn [v] t | Just c <- getPrefix "minBound." pn >>= Op.readTy = return (EPrim (APrim (PrimTypeInfo c c PrimMinBound) mempty) [] t) + primopt pn [v] t | Just c <- getPrefix "umaxBound." pn >>= Op.readTy = return (EPrim (APrim (PrimTypeInfo c c PrimUMaxBound) mempty) [] t) + primopt pn [] t | Just c <- getPrefix "const.M_PI" pn = mdo + (res,(_ta,sta)) <- boxPrimitive dataTable (ELit (LitInt (realToFrac (pi :: Double)) sta)) t; return res + primopt pn [] t | Just c <- getPrefix "const." pn = mdo + (res,(ta,sta)) <- boxPrimitive dataTable (EPrim (APrim (CConst c ta) mempty) [] sta) t; return res + primopt pn [] _ | Just c <- getPrefix "error." pn = return (EError c orig_t) + primopt _ _ _ = fail "not a primopt we care about" +processPrimPrim _ e = e + +type T = E +boxResult :: DataTable -> T -> (ExtType -> T -> E) -> Maybe E +boxResult dataTable t fn = mdo + (res,(ta,sta)) <- boxPrimitive dataTable (fn ta sta) t + return res +stringToOpTy :: String -> Ty +stringToOpTy s = case readTy s of + Just t -> t + _ -> error $ printf "stringToOpTy(%s)" s + +stringToOpTy' :: String -> String -> Ty +stringToOpTy' x s = case readTy s of + Just t -> t + _ -> error $ printf "stringToOpTy(%s): '%s'" x s + +stot :: Show a => a -> Int -> String -> Ty +stot op n s = stringToOpTy' (show op ++ show n) s +-} hunk ./src/E/PrimOpt.hs 210 ans = ELit litCons { litName = cna, litArgs = [ee], litType = orig_t } primopt pn [] t | Just c <- getPrefix "options_" pn = return (EPrim (APrim (CConst ("JHC_" ++ c) "int") mempty) [] t) primopt pn [a,w] t | Just c <- getPrefix "peek." pn >>= Op.readTy = return (EPrim (APrim (Peek c) mempty) [w,a] t) + --primopt pn [a,w] t | Just c <- getPrefix "peek." pn >>= Op.readTy = + -- boxResult dataTable t $ \_ pt -> (EPrim (APrim (Peek c) mempty) [w,a] pt) primopt pn [a,v,w] t | Just c <- getPrefix "poke." pn >>= Op.readTy = return (EPrim (APrim (Poke c) mempty) [w,a,v] t) primopt pn [v] t | Just c <- getPrefix "sizeOf." pn >>= Op.readTy = return (EPrim (APrim (PrimTypeInfo c Op.bits32 PrimSizeOf) mempty) [] t) primopt pn [v] t | Just c <- getPrefix "alignmentOf." pn >>= Op.readTy = return (EPrim (APrim (PrimTypeInfo c Op.bits32 PrimAlignmentOf) mempty) [] t) hunk ./src/E/PrimOpt.hs 225 primopt pn [] _ | Just c <- getPrefix "error." pn = return (EError c orig_t) primopt _ _ _ = fail "not a primopt we care about" processPrimPrim _ e = e + +type T = E +boxResult :: DataTable -> T -> (ExtType -> T -> E) -> Maybe E +boxResult dataTable t fn = mdo + (res,(ta,sta)) <- boxPrimitive dataTable (fn ta sta) t + return res hunk ./src/FrontEnd/Warning.hs 17 import Control.Monad.Identity import Control.Monad.Writer import Data.IORef +import Data.List +import System.IO.Unsafe + import FrontEnd.SrcLoc hunk ./src/FrontEnd/Warning.hs 21 -import GenUtil -import List import Options hunk ./src/FrontEnd/Warning.hs 22 -import System.IO.Unsafe +import Util.Gen {-# NOINLINE ioWarnings #-} ioWarnings :: IORef [Warning] hunk ./src/FrontEnd/Warning.hs 28 ioWarnings = unsafePerformIO $ newIORef [] -data Warning = Warning { warnSrcLoc :: !SrcLoc, warnType :: String, warnMessage :: String } - deriving(Eq,Ord) +data Warning = Warning { + warnSrcLoc :: !SrcLoc, + warnType :: String, + warnMessage :: String + } deriving(Eq,Ord) class Monad m => MonadWarn m where addWarning :: Warning -> m () hunk ./src/FrontEnd/Warning.hs 52 warn sl t m addDiag s = warn bogusASrcLoc "diagnostic" s -warn s t m = addWarning (Warning { warnSrcLoc = s, warnType = t, warnMessage = m }) +warn s t m = addWarning Warning + { warnSrcLoc = s, warnType = t, warnMessage = m } err t m = warn bogusASrcLoc t m warnF fn t m = warn bogusASrcLoc { srcLocFileName = fn } t m hunk ./src/FrontEnd/Warning.hs 81 processErrors' :: Bool -> [Warning] -> IO Bool processErrors' doDie ws = mapM_ s ws' >> when (die && doDie) exitFailure >> return die where ws' = filter ((`notElem` ignore) . warnType ) $ snub ws - s Warning { warnSrcLoc = sl, warnType = t, warnMessage = m } | sl == bogusASrcLoc = putErrLn $ msg t m - s Warning { warnSrcLoc = SrcLoc { srcLocFileName = fn, srcLocLine = -1 }, warnType = t ,warnMessage = m } = - putErrLn (fn ++ ": " ++ msg t m) - s Warning { warnSrcLoc = SrcLoc { srcLocFileName = fn, srcLocLine = l }, warnType = t ,warnMessage = m } = - putErrLn (fn ++ ":" ++ pad 3 (show l) ++ " - " ++ msg t m) + s Warning { warnSrcLoc = sl, warnType = t, warnMessage = m } + | sl == bogusASrcLoc = putErrLn $ msg t m + s Warning { warnSrcLoc = SrcLoc { srcLocFileName = fn, srcLocLine = -1 }, + warnType = t ,warnMessage = m } = putErrLn (fn ++ ": " ++ msg t m) + s Warning { warnSrcLoc = SrcLoc { srcLocFileName = fn, srcLocLine = l }, + warnType = t ,warnMessage = m } = putErrLn (fn ++ ":" ++ pad 3 (show l) ++ " - " ++ msg t m) die = (not $ null $ intersect (map warnType ws') fatal) && not (optKeepGoing options) hunk ./src/FrontEnd/Warning.hs 89 +--data WarnType +-- = UndefinedName Name +-- | AmbiguousName Name +-- | MultiplyDefined Name +-- | UnknownImport Module +-- | ParseError + fatal = [ "undefined-name", "ambiguous-name", hunk ./src/FrontEnd/Warning.hs 106 "missing-dep", "invalid-decl", "invalid-assoc", + "invalid-primitive", "type-synonym-recursive", "type-synonym-partialap" ] hunk ./src/FrontEnd/Warning.hs 113 ignore = ["h98-emptydata"] instance Show Warning where - show Warning { warnSrcLoc = sl, warnType = t, warnMessage = m } | sl == bogusASrcLoc = msg t m - show Warning { warnSrcLoc = SrcLoc { srcLocFileName = fn, srcLocLine = l }, warnType = t ,warnMessage = m } = + show Warning { warnSrcLoc = sl, warnType = t, warnMessage = m } + | sl == bogusASrcLoc = msg t m + show Warning { warnSrcLoc = SrcLoc { srcLocFileName = fn, srcLocLine = l }, + warnType = t ,warnMessage = m } = (fn ++ ":" ++ pad 3 (show l) ++ " - " ++ msg t m) msg "diagnostic" m = "Diagnostic: " ++ m msg t m = (if t `elem` fatal then "Error: " else "Warning: ") ++ m [fix trailing whitespace. add fix-whitespace make target John Meacham **20120127014502 Ignore-this: d34de915c0756575d1672beb516de3c4 ] hunk ./Makefile.am 267 echo "{-@Options 1" > $@ ./jhc --help | sed -e 's/^/ /' >> $@ +fix-whitespace: + find src -not \( -name .svn -prune -o -name .git -prune \) -type f -print0 | xargs -0 sed -i -E 's/[[:space:]]*$$//' + find lib -not \( -name .svn -prune -o -name .git -prune \) -type f -print0 | xargs -0 sed -i -E 's/[[:space:]]*$$//' + jhc.1 : $(MAKE) man hunk ./lib/Test/QuickCheck/Batch.hs 168 -- inside "r" might be _|_, but anyway.... r <- theTest -- Now, we turn off the watcher. - -- Ignored if the watcher is already dead, + -- Ignored if the watcher is already dead, -- (unless some unlucky thread picks up the same name) killThread watcher return r) hunk ./lib/applicative/Control/Applicative.hs 181 -- | Replace the value. --(<$) :: Functor f => a -> f b -> f a --(<$) = (<$>) . const - + -- | Sequence actions, discarding the value of the first argument. (*>) :: Applicative f => f a -> f b -> f b (*>) = liftA2 (const id) hunk ./lib/applicative/Control/Applicative.hs 185 - + -- | Sequence actions, discarding the value of the second argument. (<*) :: Applicative f => f a -> f b -> f a (<*) = liftA2 const hunk ./lib/applicative/Control/Applicative.hs 189 - + -- | A variant of '<*>' with the arguments reversed. (<**>) :: Applicative f => f a -> f (a -> b) -> f b (<**>) = liftA2 (flip ($)) hunk ./lib/base/Control/Monad/Fix.hs 70 -- IO: instance MonadFix IO where - mfix = fixIO + mfix = fixIO instance MonadFix ((->) r) where mfix f = \ r -> let a = f a r in a hunk ./lib/base/Data/Version.hs 82 deriving ( Read,Show ) instance Eq Version where - v1 == v2 = versionBranch v1 == versionBranch v2 + v1 == v2 = versionBranch v1 == versionBranch v2 && sort (versionTags v1) == sort (versionTags v2) -- tags may be in any order hunk ./lib/base/Data/Version.hs 93 -- A concrete representation of 'Version' -- | Provides one possible concrete representation for 'Version'. For --- a version with 'versionBranch' @= [1,2,3]@ and 'versionTags' +-- a version with 'versionBranch' @= [1,2,3]@ and 'versionTags' -- @= [\"tag1\",\"tag2\"]@, the output will be @1.2.3-tag1-tag2@. -- showVersion :: Version -> String hunk ./lib/base/Data/Version.hs 98 showVersion (Version branch tags) - = concat (intersperse "." (map show branch)) ++ + = concat (intersperse "." (map show branch)) ++ concatMap ('-':) tags hunk ./lib/base/Foreign/C.hs 6 -- Module : Foreign.C -- Copyright : (c) The FFI task force 2001 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : ffi@haskell.org -- Stability : provisional -- Portability : portable hunk ./lib/base/System/Directory.hs 44 createDirectory :: FilePath -> IO () -createDirectory fp = throwErrnoIfMinus1_ fp $ withCString fp $ \cs -> mkdir cs (-1) +createDirectory fp = throwErrnoIfMinus1_ fp $ withCString fp $ \cs -> mkdir cs (-1) removeDirectory :: FilePath -> IO () hunk ./lib/base/System/Random.hs 226 -- #else -- stdSplit :: StdGen -> (StdGen, StdGen) -- stdSplit std@(StdGen s1 _) = (std, unsafePerformIO (mkStdRNG (fromInt s1))) --- #endif +-- #endif --ptr_a = unsafePerformIO $ malloc hunk ./lib/base/base.yaml 6 Hs-Source-Dir: . Extensions: ForeignFunctionInterface Options: [ -pjhc, --noauto ] -Exposed-Modules: +Exposed-Modules: - Control.Exception - Control.Monad - Data.Array hunk ./lib/ext/containers.patch 12 -g i x is = if p x then i:is else is + g i x is = if p x then i:is else is #endif - + {-# INLINE findIndicesR #-} @@ -1513,7 +1513,7 @@ foldlWithIndex g n xs) hunk ./lib/ext/containers.patch 21 -g is i x = if p x then i:is else is + g is i x = if p x then i:is else is #endif - + ------------------------------------------------------------------------ hunk ./lib/haskell98/Array.hs 3 module Array ( module Ix, -- export all of Ix for convenience - Array, array, listArray, (!), bounds, indices, elems, assocs, + Array, array, listArray, (!), bounds, indices, elems, assocs, accumArray, (//), accum, ixmap ) where hunk ./lib/haskell98/CPUTime.hs 2 module CPUTime ( - getCPUTime, cpuTimePrecision + getCPUTime, cpuTimePrecision ) where import System.CPUTime hunk ./lib/haskell98/Char.hs 2 module Char ( - isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower, - isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum, + isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower, + isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum, digitToInt, intToDigit, toUpper, toLower, ord, chr, hunk ./lib/haskell98/Complex.hs 2 module Complex ( - Complex((:+)), realPart, imagPart, conjugate, - mkPolar, cis, polar, magnitude, phase + Complex((:+)), realPart, imagPart, conjugate, + mkPolar, cis, polar, magnitude, phase ) where import Data.Complex hunk ./lib/haskell98/Directory.hs 2 module Directory ( - Permissions( Permissions, readable, writable, executable, searchable ), - createDirectory, removeDirectory, removeFile, + Permissions( Permissions, readable, writable, executable, searchable ), + createDirectory, removeDirectory, removeFile, renameDirectory, renameFile, getDirectoryContents, getCurrentDirectory, setCurrentDirectory, doesFileExist, doesDirectoryExist, hunk ./lib/haskell98/Directory.hs 8 getPermissions, setPermissions, - getModificationTime + getModificationTime ) where import System.Directory hunk ./lib/haskell98/IO.hs 6 IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode), BufferMode(NoBuffering,LineBuffering,BlockBuffering), SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd), - stdin, stdout, stderr, + stdin, stdout, stderr, openFile, hClose, hFileSize, hIsEOF, isEOF, hunk ./lib/haskell98/IO.hs 8 - hSetBuffering, hGetBuffering, hFlush, - hGetPosn, hSetPosn, hSeek, - hWaitForInput, hReady, hGetChar, hGetLine, hLookAhead, hGetContents, + hSetBuffering, hGetBuffering, hFlush, + hGetPosn, hSetPosn, hSeek, + hWaitForInput, hReady, hGetChar, hGetLine, hLookAhead, hGetContents, hPutChar, hPutStr, hPutStrLn, hPrint, hIsOpen, hIsClosed, hIsReadable, hIsWritable, hIsSeekable, hunk ./lib/haskell98/IO.hs 13 - isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError, + isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError, isFullError, isEOFError, hunk ./lib/haskell98/IO.hs 15 - isIllegalOperation, isPermissionError, isUserError, + isIllegalOperation, isPermissionError, isUserError, ioeGetErrorString, ioeGetHandle, ioeGetFileName, try, bracket, bracket_, hunk ./lib/haskell98/List.hs 25 take, drop, splitAt, takeWhile, dropWhile, span, break, lines, words, unlines, unwords, reverse, and, or, any, all, elem, notElem, lookup, - sum, product, maximum, minimum, concatMap, + sum, product, maximum, minimum, concatMap, zip, zip3, zipWith, zipWith3, unzip, unzip3 ) where hunk ./lib/haskell98/Locale.hs 5 TimeLocale(..), defaultTimeLocale ) where -import System.Locale ( +import System.Locale ( -- just the bits that are specified by Haskell 98 TimeLocale(TimeLocale,wDays,months,amPm,dateTimeFmt, dateFmt,timeFmt,time12Fmt), hunk ./lib/haskell98/Monad.hs 5 MonadPlus(mzero, mplus), join, guard, when, unless, ap, msum, - filterM, mapAndUnzipM, zipWithM, zipWithM_, foldM, + filterM, mapAndUnzipM, zipWithM, zipWithM_, foldM, liftM, liftM2, liftM3, liftM4, liftM5, -- ...and what the Prelude exports hunk ./lib/haskell98/Monad.hs 11 Monad((>>=), (>>), return, fail), Functor(fmap), - mapM, mapM_, sequence, sequence_, (=<<), + mapM, mapM_, sequence, sequence_, (=<<), ) where import Control.Monad hunk ./lib/haskell98/Time.hs 2 module Time ( - ClockTime, + ClockTime, Month(January,February,March,April,May,June, July,August,September,October,November,December), Day(Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday), hunk ./lib/haskell98/Time.hs 12 tdMin, tdSec, tdPicosec), getClockTime, addToClockTime, diffClockTimes, toCalendarTime, toUTCTime, toClockTime, - calendarTimeToString, formatCalendarTime + calendarTimeToString, formatCalendarTime ) where import System.Time hunk ./src/DerivingDrift/DataP.hs 5 import FrontEnd.HsSyn -data Statement = DataStmt | NewTypeStmt +data Statement = DataStmt | NewTypeStmt deriving (Eq,Show) data Data = D { hunk ./src/E/FromHs.hs 295 let e2 = atomizeAp mempty False dataTable e2' return (hsRuleIsMeta pr,hsRuleString pr,( snds (cs' ++ ts) ),eval $ smt $ sma e1,e2) -convertE :: MonadWarn m => TiData -> ClassHierarchy -> Map.Map Name Type +convertE :: MonadWarn m => TiData -> ClassHierarchy -> Map.Map Name Type -> DataTable -> SrcLoc -> HsExp -> m E convertE tiData classHierarchy assumps dataTable srcLoc exp = do hunk ./src/E/FromHs.hs 298 - [(_,_,e)] <- convertDecls tiData mempty classHierarchy assumps dataTable + [(_,_,e)] <- convertDecls tiData mempty classHierarchy assumps dataTable [HsPatBind srcLoc (HsPVar v_silly) (HsUnGuardedRhs exp) []] return e hunk ./src/E/FromHs.hs 349 return (eLam y fgy) {-# NOINLINE convertDecls #-} -convertDecls :: MonadWarn m => TiData -> IdMap Properties - -> ClassHierarchy -> Map.Map Name Type -> DataTable +convertDecls :: MonadWarn m => TiData -> IdMap Properties + -> ClassHierarchy -> Map.Map Name Type -> DataTable -> [HsDecl] -> m [(Name,TVr,E)] convertDecls tiData props classHierarchy assumps dataTable hsDecls = res where res = do hunk ./src/E/FromHs.hs 458 es <- newVars [ t | t <- ts, not (sortKindLike t) ] --let result = foldr ($) (processPrimPrim dataTable $ EPrim prim [ EVar e | e <- es, not (tvrType e == tUnit)] rt) (map ELam es) --result <- return (processPrimPrim dataTable $ EPrim prim [ EVar e | e <- es, not (tvrType e == tUnit)] rt) - result <- processPrim dataTable sLoc (toAtom cn) + result <- processPrim dataTable sLoc (toAtom cn) [ EVar e | e <- es, not (tvrType e == tUnit)] rt req return [(name,setProperty prop_INLINE var, lamt $ foldr ($) result (map ELam es))] hunk ./src/StringTable/Atom.hsc 58 hash32 :: a -> Word32 instance HasHash Atom where - hash32 a = let (x,y) = fromAtom a :: CStringLen in + hash32 a = let (x,y) = fromAtom a :: CStringLen in unsafePerformIO $ hash2 0 x (fromIntegral y) instance HasHash BS.ByteString where hunk ./src/StringTable/Atom.hsc 66 BS.unsafeUseAsCStringLen bs $ \ (x,y) -> hash2 0 x (fromIntegral y) instance HasHash String where - hash32 s = unsafePerformIO $ withCStringLen s $ + hash32 s = unsafePerformIO $ withCStringLen s $ \ (x,y) -> hash2 0 x (fromIntegral y) instance FromAtom (String -> String) where hunk ./src/StringTable/Atom.hsc 102 toAtomIO bs = BS.unsafeUseAsCStringLen bs toAtomIO instance FromAtom CStringLen where - fromAtom a@(Atom v) = (stPtr a,fromIntegral $ + fromAtom a@(Atom v) = (stPtr a,fromIntegral $ (v `shiftR` (#const ATOM_LEN_SHIFT)) .&. (#const ATOM_LEN_MASK)) instance FromAtom Word where hunk ./src/StringTable/Atom.hsc 130 readsPrec _ s = [ (toAtom s,"") ] intToAtom :: Monad m => Int -> m Atom -intToAtom i = if isValidAtom i then return (Atom $ fromIntegral i) else +intToAtom i = if isValidAtom i then return (Atom $ fromIntegral i) else fail $ "intToAtom: " ++ show i isValidAtom :: Int -> Bool hunk ./src/Util/BitSet.hs 24 mempty = BitSet 0 mappend (BitSet a) (BitSet b) = BitSet (a .|. b) mconcat ss = foldl' mappend mempty ss - + instance Unionize BitSet where BitSet a `difference` BitSet b = BitSet (a .&. complement b) BitSet a `intersection` BitSet b = BitSet (a .&. b) hunk ./src/Util/BitSet.hs 31 type instance Elem BitSet = Int -instance Collection BitSet where +instance Collection BitSet where -- type Elem BitSet = Int singleton i = BitSet (bit i) fromList ts = BitSet (foldl' setBit 0 ts) hunk ./src/Util/BitSet.hs 50 f w n r = if even w || not (fn n) then f w1 n1 r else f w1 n1 (setBit r n) where !n1 = n + 1 !w1 = w `shiftR` 1 - + instance IsEmpty BitSet where isEmpty (BitSet n) = n == 0 hunk ./src/Util/BitSet.hs 98 deriving(Monoid,Unionize,HasSize,Eq,Ord,IsEmpty) type instance Elem (EnumBitSet a) = a -instance Enum a => Collection (EnumBitSet a) where +instance Enum a => Collection (EnumBitSet a) where singleton i = EBS $ singleton (fromEnum i) fromList ts = EBS $ fromList (map fromEnum ts) toList (EBS w) = map toEnum $ toList w hunk ./src/Util/BitSet.hs 109 member (fromEnum -> i) (EBS v) = member i v insert (fromEnum -> i) (EBS v) = EBS $ insert i v sfilter f (EBS v) = EBS $ sfilter (f . toEnum) v - + {- instance Enum a => BuildSet a (EnumBitSet a) where hunk ./src/Util/Graph.hs 56 newGraphReachable :: Ord k => [n] -> (n -> k) -> (n -> [k]) -> ([k] -> [n],Graph n) newGraphReachable ns fn fd = (rable,ng) where (vmap,ng) = newGraph' ns fn fd - rable ks = Util.Graph.reachable ng [ v | Just v <- map (flip Map.lookup vmap) ks ] + rable ks = Util.Graph.reachable ng [ v | Just v <- map (flip Map.lookup vmap) ks ] reachableFrom :: Ord k => (n -> k) -> (n -> [k]) -> [n] -> [k] -> [n] reachableFrom fn fd ns = fst $ newGraphReachable ns fn fd Context: [add IsString instance for Atom John Meacham **20120126123532 Ignore-this: 8870a7c5146affb1d9851433267d87d5 ] [fix storable instances John Meacham **20120126123433 Ignore-this: a443b85bf55b93333dc4ab865f81b46c ] [whitespace/formatting cleanups John Meacham **20120125214237 Ignore-this: e58fb7393dc01e27e40973427f85c48e ] [add a list of names to display in short from when printing E code John Meacham **20120125214141 Ignore-this: 61fe6d698e1e7c4ea6ac65ae2b650365 ] [fix generation of man page. John Meacham **20120125132712 Ignore-this: 857599eafa0630254e7bc284a5dee1a4 ] [remove unused names from data/names.txt and DataConstructors.hs John Meacham **20120125125523 Ignore-this: 8ce08c088204d8f9552ed583a6d3e0a0 ] [TAG ejnagteuk John Meacham **20120125115759 Ignore-this: 410e549a607234cd3a297780f366ab4b ] Patch bundle hash: b4655b6c71d85340035e942a1a2b52b656d4b71d