New patches: [update building documentation John Meacham **20090305033739 Ignore-this: 61bb8a116f5c0f2b78bc1ce8133715ef ] hunk ./docs/building.mkd.in 5 =================== All versions of jhc are available from the -[Download Directory](http://repetae.net/computer/jhc/drop/). The project is +[Download Directory](http://repetae.net/dist/). The project is also under darcs revision control however the build process from darcs is somewhat more involved. For information on getting the source code from darcs and building it, see the [Development Page](development.shtml). hunk ./docs/building.mkd.in 15 This is by far the easiest way to go about it if you have an rpm based system, an RPM for x86 based systems can be instaled from: -. +. There is also a 'src' rpm in the download directory for rebuilding from source. Building from the tarball hunk ./docs/building.mkd.in 27 * GHC 6.8.2 or better * haskell library [binary](http://hackage.haskell.org/cgi-bin/hackage-scripts/package/binary) * haskell library [zlib](http://hackage.haskell.org/cgi-bin/hackage-scripts/package/zlib) + * haskell library [utf8-string](http://hackage.haskell.org/cgi-bin/hackage-scripts/package/utf8-string) You can get the tarball hunk ./docs/building.mkd.in 30 -at . In order +at . In order to build it, download it into a directory and perform the following tar zxvf @PACKAGE@-@VERSION@.tar.gz [fix foreign import of c_strcmp to have pointers as arguments John Meacham **20090305100633 Ignore-this: 60f4bf78fc357e158630b099a874ab7c ] hunk ./lib/base/Data/Typeable.hs 24 instance Eq TypeRep where - TypeRep a xs == TypeRep b ys = case c_strcmp a b of + TypeRep a xs == TypeRep b ys = case c_strcmp (Addr_ a) (Addr_ b) of 0 -> xs == ys _ -> False hunk ./lib/base/Data/Typeable.hs 29 -foreign import ccall "strcmp" c_strcmp :: Addr__ -> Addr__ -> Int +foreign import ccall "strcmp" c_strcmp :: Addr_ -> Addr_ -> Int {- foreign import primitive ptypeOf :: a -> TypeRep [fix Grin.Devolve to catch all lifted functions in a single pass and not have to recurse John Meacham **20090305101654 Ignore-this: 77c2df6b5b0d325cc9e4c7f054a6dfa ] hunk ./Grin/Devolve.hs 32 devolveGrin :: Grin -> IO Grin devolveGrin grin = do - putStrLn "-- devolve" col <- newIORef [] let g (n,l :-> r) = f r >>= \r -> return (n,l :-> r) f lt@Let { expDefs = defs, expBody = body } = do hunk ./Grin/Devolve.hs 54 pr = runIdentity $ proc r proc (App a as t) | Just xs <- Map.lookup a pmap = return (App a (as ++ Set.toList xs) t) proc e = mapExpExp proc e - mapM_ print (Map.toList pmap) - --nmaps <- mapM (g . fst) nmaps - modifyIORef col (++ fsts nmaps) - --mapExpExp f $ updateLetProps lt { expDefs = rmaps, expBody = proc body } - return $ updateLetProps lt { expDefs = rmaps, expBody = runIdentity $ proc body } + --mapM_ print (Map.toList pmap) + nmaps <- mapM (g . fst) nmaps + modifyIORef col (++ nmaps) + mapExpExp f $ updateLetProps lt { expDefs = rmaps, expBody = runIdentity $ proc body } f e = mapExpExp f e nf <- mapM g (grinFuncs grin) lf <- readIORef col hunk ./Grin/Devolve.hs 62 let ntenv = extendTyEnv [ createFuncDef False x y | (x,y) <- lf ] (grinTypeEnv grin) - let ng = setGrinFunctions (lf ++ nf) grin { grinPhase = PostDevolve, grinTypeEnv = ntenv } - if null lf then return ng else devolveGrin ng + return $ setGrinFunctions (lf ++ nf) grin { grinPhase = PostDevolve, grinTypeEnv = ntenv } + --if null lf then return ng else devolveGrin ng + --if null lf then return ng else devolveGrin ng data Env = Env { [remove superfluous 'Atom' argument to the tyvar [binary format change] John Meacham **20090305110459 Ignore-this: 7fd3ede126cafb0f9372c539154f9713 ] hunk ./E/FromHs.hs 119 -fromTyvar (Tyvar _ n k) = tVr (toId n) (kind k) +fromTyvar (Tyvar n k) = tVr (toId n) (kind k) fromSigma (TForAll vs (_ :=> t)) = (map fromTyvar vs, tipe t) fromSigma t = ([], tipe t) hunk ./FrontEnd/Class.hs 455 f (TExists ta (ps :=> t)) = tickle f (TExists (map at ta) (ps :=> t)) f t = tickle f t - at (Tyvar _ n k) = tyvar (updateName (++ foo) n) k + at (Tyvar n k) = tyvar (updateName (++ foo) n) k updateName f n = toName nt (md,f nm) where (nt,(md::String,nm)) = fromName n -- qt = (newCntxt ++ restContext) :=> t hunk ./FrontEnd/Representation.hs 119 -- Unquantified type variables -data Tyvar = Tyvar { tyvarAtom :: {-# UNPACK #-} !Atom, tyvarName :: !Name, tyvarKind :: Kind } +data Tyvar = Tyvar { tyvarName :: !Name, tyvarKind :: Kind } {- derive: Binary -} instance Show Tyvar where hunk ./FrontEnd/Representation.hs 135 -tyvar n k = Tyvar (toAtom $ show n) n k +tyvar n k = Tyvar n k instance Eq Tyvar where hunk ./FrontEnd/Representation.hs 138 - Tyvar { tyvarAtom = x } == Tyvar { tyvarAtom = y } = x == y - Tyvar { tyvarAtom = x } /= Tyvar { tyvarAtom = y } = x /= y + Tyvar { tyvarName = x } == Tyvar { tyvarName = y } = x == y + Tyvar { tyvarName = x } /= Tyvar { tyvarName = y } = x /= y instance Ord Tyvar where hunk ./FrontEnd/Representation.hs 142 - compare (Tyvar { tyvarAtom = x }) (Tyvar { tyvarAtom = y }) = compare x y - (Tyvar { tyvarAtom = x }) <= (Tyvar { tyvarAtom = y }) = x <= y - (Tyvar { tyvarAtom = x }) >= (Tyvar { tyvarAtom = y }) = x >= y - (Tyvar { tyvarAtom = x }) < (Tyvar { tyvarAtom = y }) = x < y - (Tyvar { tyvarAtom = x }) > (Tyvar { tyvarAtom = y }) = x > y + compare (Tyvar { tyvarName = x }) (Tyvar { tyvarName = y }) = compare x y + (Tyvar { tyvarName = x }) <= (Tyvar { tyvarName = y }) = x <= y + (Tyvar { tyvarName = x }) >= (Tyvar { tyvarName = y }) = x >= y + (Tyvar { tyvarName = x }) < (Tyvar { tyvarName = y }) = x < y + (Tyvar { tyvarName = x }) > (Tyvar { tyvarName = y }) = x > y hunk ./FrontEnd/Representation.hs 199 pprint tv = tshow (tyvarName tv) instance Binary Tyvar where - put (Tyvar aa ab ac) = do + put (Tyvar aa ab) = do put aa put ab hunk ./FrontEnd/Representation.hs 202 - put ac get = do aa <- get ab <- get hunk ./FrontEnd/Representation.hs 205 - ac <- get - return (Tyvar aa ab ac) + return (Tyvar aa ab) instance FromTupname HsName where hunk ./FrontEnd/Representation.hs 287 vo <- maybeLookupName tyvar case vo of Just c -> return $ atom $ text c - Nothing -> return $ atom $ tshow (tyvarAtom tyvar) + Nothing -> return $ atom $ tshow (tyvarName tyvar) f (TAp (TCon (Tycon n _)) x) | n == tc_List = do x <- f x return $ atom (char '[' <> unparse x <> char ']') hunk ./FrontEnd/Tc/Class.hs 121 byInst :: Monad m => Pred -> Inst -> m [Pred] byInst p Inst { instHead = ps :=> h } = do u <- matchPred h p - return (map (inst mempty (Map.fromList [ (tyvarAtom mv,t) | (mv,t) <- u ])) ps) + return (map (inst mempty (Map.fromList [ (tyvarName mv,t) | (mv,t) <- u ])) ps) matchPred :: Monad m => Pred -> Pred -> m [(Tyvar,Type)] matchPred x@(IsIn c t) y@(IsIn c' t') hunk ./FrontEnd/Tc/Monad.hs 66 import Text.PrettyPrint.HughesPJ(Doc) -import StringTable.Atom import FrontEnd.Diagnostic import Doc.DocLike import Doc.PPrint hunk ./FrontEnd/Tc/Monad.hs 271 class Instantiate a where - inst:: Map.Map Int Type -> Map.Map Atom Type -> a -> a + inst:: Map.Map Int Type -> Map.Map Name Type -> a -> a instance Instantiate Type where inst mm ts (TAp l r) = tAp (inst mm ts l) (inst mm ts r) hunk ./FrontEnd/Tc/Monad.hs 277 inst mm ts (TArrow l r) = TArrow (inst mm ts l) (inst mm ts r) inst mm _ t@TCon {} = t - inst mm ts (TVar tv ) = case Map.lookup (tyvarAtom tv) ts of + inst mm ts (TVar tv ) = case Map.lookup (tyvarName tv) ts of Just t' -> t' Nothing -> (TVar tv) hunk ./FrontEnd/Tc/Monad.hs 280 - inst mm ts (TForAll as qt) = TForAll as (inst mm (foldr Map.delete ts (map tyvarAtom as)) qt) - inst mm ts (TExists as qt) = TExists as (inst mm (foldr Map.delete ts (map tyvarAtom as)) qt) + inst mm ts (TForAll as qt) = TForAll as (inst mm (foldr Map.delete ts (map tyvarName as)) qt) + inst mm ts (TExists as qt) = TExists as (inst mm (foldr Map.delete ts (map tyvarName as)) qt) inst mm ts (TMetaVar mv) | Just t <- Map.lookup (metaUniq mv) mm = t inst mm ts (TMetaVar mv) = TMetaVar mv inst mm ts (TAssoc tc as bs) = TAssoc tc (map (inst mm ts) as) (map (inst mm ts) bs) hunk ./FrontEnd/Tc/Monad.hs 378 f t _ = return t -- f t _ = error $ "boxySpec: " ++ show t (t',vs) <- runWriterT (f t as) - addPreds $ inst mempty (Map.fromList [ (tyvarAtom bt,s) | (bt,s) <- vs ]) ps + addPreds $ inst mempty (Map.fromList [ (tyvarName bt,s) | (bt,s) <- vs ]) ps return (sortGroupUnderFG fst snd vs,t') hunk ./FrontEnd/Tc/Type.hs 79 applyTyvarMap :: [(Tyvar,Type)] -> Type -> Type applyTyvarMap ts t = f initMp t where - initMp = Map.fromList [ (tyvarAtom v,t) | (v,t) <- ts ] + initMp = Map.fromList [ (tyvarName v,t) | (v,t) <- ts ] -- XXX name capture! hunk ./FrontEnd/Tc/Type.hs 81 - f mp (TForAll as qt) = TForAll as (fq (foldr Map.delete mp (map tyvarAtom as)) qt) - f mp (TExists as qt) = TExists as (fq (foldr Map.delete mp (map tyvarAtom as)) qt) - f mp (TVar tv) = case Map.lookup (tyvarAtom tv) mp of + f mp (TForAll as qt) = TForAll as (fq (foldr Map.delete mp (map tyvarName as)) qt) + f mp (TExists as qt) = TExists as (fq (foldr Map.delete mp (map tyvarName as)) qt) + f mp (TVar tv) = case Map.lookup (tyvarName tv) mp of Just t' -> t' Nothing -> (TVar tv) f mp t = tickle (f mp) t hunk ./FrontEnd/Tc/Unify.hs 217 bm t1@TForAll {} (TForAll as2 qt2) = do TForAll as1 (ps1 :=> r1) <- freshSigma t1 - let (ps2 :=> r2) = inst mempty (Map.fromList [ (tyvarAtom a2,TVar a1) | a1 <- as1 | a2 <- as2 ]) qt2 + let (ps2 :=> r2) = inst mempty (Map.fromList [ (tyvarName a2,TVar a1) | a1 <- as1 | a2 <- as2 ]) qt2 printRule "SEQ2" boxyMatch r1 r2 assertEquivalant ps1 ps2 [update version number to 0.6.0 John Meacham **20090305110630 Ignore-this: 77735e27039f884c5a83ff2fd197047 ] hunk ./configure.ac 1 -AC_INIT([jhc],[0.5.20090304]) +AC_INIT([jhc],[0.6.0]) AC_CONFIG_SRCDIR(Main.hs) AC_CONFIG_MACRO_DIR(ac-macros) AC_CONFIG_AUX_DIR(ac-macros) [code cleanups and tweak strictness and UNPACK pragmas John Meacham **20090306014027 Ignore-this: 4894fdf4c9959a33708f4e48e7165287 ] hunk ./FrontEnd/Representation.hs 43 import Data.IORef import Text.PrettyPrint.HughesPJ(Doc) -import StringTable.Atom import Data.Binary import Doc.DocLike import Doc.PPrint hunk ./FrontEnd/Representation.hs 65 deriving(Eq,Ord) {-! derive: Binary !-} -data Type = TVar { typeVar :: {-# UNPACK #-} !Tyvar } - | TCon { typeCon :: !Tycon } - | TAp Type Type - | TArrow Type Type - | TForAll { typeArgs :: [Tyvar], typeBody :: (Qual Type) } - | TExists { typeArgs :: [Tyvar], typeBody :: (Qual Type) } +data Type = TVar { typeVar :: !Tyvar } + | TCon { typeCon :: !Tycon } + | TAp Type Type + | TArrow Type Type + | TForAll { typeArgs :: [Tyvar], typeBody :: (Qual Type) } + | TExists { typeArgs :: [Tyvar], typeBody :: (Qual Type) } | TMetaVar { metaVar :: MetaVar } | TAssoc { typeCon :: !Tycon, typeClassArgs :: [Type], typeExtraArgs :: [Type] } deriving(Ord,Show) hunk ./FrontEnd/Representation.hs 76 {-! derive: Binary !-} -data MetaVar = MetaVar { metaUniq :: !Int, metaKind :: Kind, metaRef :: (IORef (Maybe Type)), metaType :: MetaVarType } -- ^ used only in typechecker +-- | metavars are used in type checking +data MetaVar = MetaVar { + metaUniq :: {-# UNPACK #-} !Int, + metaKind :: Kind, + metaRef :: {-# UNPACK #-} !(IORef (Maybe Type)), + metaType :: MetaVarType + } {-! derive: Binary !-} instance Eq MetaVar where hunk ./FrontEnd/Representation.hs 124 -- Unquantified type variables -data Tyvar = Tyvar { tyvarName :: !Name, tyvarKind :: Kind } +data Tyvar = Tyvar { tyvarName :: {-# UNPACK #-} !Name, tyvarKind :: Kind } {- derive: Binary -} instance Show Tyvar where [don't include '()' in parameters to primitives. John Meacham **20090306044327 Ignore-this: 98e851267a51d465e9763b04932cf706 ] hunk ./E/FromHs.hs 464 let (ts,rt) = argTypes' ty prim = APrim (PrimPrim $ toAtom cn) req es <- newVars [ t | t <- ts, not (sortKindLike t) ] - let result = foldr ($) (processPrimPrim dataTable $ EPrim prim (map EVar es) rt) (map ELam es) + 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)] cDecl (HsForeignDecl _ (FfiSpec (ImportAddr rcn req) _ _) n _) = do let name = toName Name.Val n [add various ways to test compile time properties in Jhc.Options John Meacham **20090306044408 Ignore-this: 4570f7563434e0e2c51a256df244d80 ] hunk ./Grin/FromE.hs 37 import Name.Id import Name.Name import Name.Names +import Name.VConsts import Options import Stats(mtick) import Support.CanType hunk ./Grin/FromE.hs 138 f x = (x,map (toType tyINode . tvrType ) as,toTypes TyNode (getType (e::E) :: E)) -stringNameToTy :: String -> Ty -stringNameToTy n = TyPrim (archOpTy archInfo n) toType :: Ty -> E -> Ty toType node = toty . followAliases mempty where hunk ./Grin/FromE.hs 414 ce (EPrim ap@(APrim (PrimPrim prim) _) as _) = f (fromAtom prim) as where + pconst s = Prim (APrim CConst { primConst = s, primRetType = "int" } mempty) [] [tIntzh] + -- options + + f "options_target" [_] = do return $ Return [toUnVal (0::Int)] + f "options_isWindows" [_] = do return $ pconst "JHC_isWindows" + f "options_isPosix" [_] = do return $ pconst "JHC_isPosix" + f "options_isBigEndian" [_] = do return $ pconst "JHC_isBigEndian" -- artificial dependencies f "newWorld__" [_] = do hunk ./data/rts/jhc_rts.c 11 static HsInt jhc_stdrnd[2] A_UNUSED = { 1 , 1 }; static HsInt jhc_data_unique A_UNUSED; +#ifdef __WIN32__ +static char *jhc_options_os = "mingw32"; +static char *jhc_options_arch = "i386"; +#else +struct utsname jhc_utsname; +static char *jhc_options_os = "(unknown os)"; +static char *jhc_options_arch = "(unknown arch)"; +#endif + #if _JHC_PROFILE hunk ./data/rts/jhc_rts.c 169 jhc_argc = argc - 1; jhc_argv = argv + 1; jhc_progname = argv[0]; +#if JHC_isPosix + if(!uname(&jhc_utsname)) { + jhc_options_arch = jhc_utsname.machine; + jhc_options_os = jhc_utsname.sysname; + } +#endif setlocale(LC_ALL,""); if (jhc_setjmp(jhc_uncaught)) jhc_error("Uncaught Exception"); hunk ./data/rts/jhc_rts_header.h 17 #include #ifndef __WIN32__ #include +#include +#include #endif #include hunk ./data/rts/jhc_rts_header.h 85 #define ALIGN(a,n) ((n) - 1 + ((a) - ((n) - 1) % (a))) +#ifdef __WIN32__ +#define JHC_isWindows 1 +#define JHC_isBigEndian 0 +#else +#define JHC_isWindows 0 +#define JHC_isBigEndian (__BYTE_ORDER == __BIG_ENDIAN) +#endif + +#define JHC_isPosix (!JHC_isWindows) hunk ./lib/base/Jhc/Options.hs 1 -{-# OPTIONS_JHC -N -fffi #-} +{-# OPTIONS_JHC -N -fffi -fcpp -funboxed-values #-} hunk ./lib/base/Jhc/Options.hs 3 -module Jhc.Options(target,Target(..)) where +module Jhc.Options( +#ifdef __JHC__ + isWindows, + isPosix, + target, + isBigEndian, + isLittleEndian, +#endif + Target(..) + ) where + +import Jhc.Order +import Jhc.Enum +import Jhc.Prim +import Jhc.Types +import Jhc.Basics data Target = Grin | GhcHs | DotNet | Java hunk ./lib/base/Jhc/Options.hs 21 + deriving(Eq,Ord,Enum) + + + + +#ifdef __JHC__ + +isBigEndian,isLittleEndian :: Bool +isLittleEndian = not isBigEndian + +foreign import primitive "box" boxTarget :: Enum__ -> Target +foreign import primitive "box" boxBool :: Enum__ -> Bool + hunk ./lib/base/Jhc/Options.hs 35 +target = boxTarget (options_target ()) +isWindows = boxBool (options_isWindows ()) +isPosix = boxBool (options_isPosix ()) +isBigEndian = boxBool (options_isBigEndian ()) hunk ./lib/base/Jhc/Options.hs 40 -{-# NOINLINE target #-} -target :: Target -target = unknown_target +foreign import primitive options_target :: () -> Enum__ +foreign import primitive options_isWindows :: () -> Bool__ +foreign import primitive options_isPosix :: () -> Bool__ +foreign import primitive options_isBigEndian :: () -> Bool__ hunk ./lib/base/Jhc/Options.hs 45 -foreign import primitive unknown_target :: Target +#endif hunk ./lib/base/System/Info.hs 1 -{-# OPTIONS_JHC -N #-} -module System.Info where +{-# OPTIONS_JHC -fffi #-} +module System.Info(compilerName,compilerVersion,os,arch) where hunk ./lib/base/System/Info.hs 4 +import Foreign.C.String +import System.IO.Unsafe +import Foreign compilerName = "jhc" compilerVersion = "0" hunk ./lib/base/System/Info.hs 10 + +os = unsafePerformIO $ peekCAString =<< peek options_os +arch = unsafePerformIO $ peekCAString =<< peek options_arch + + +foreign import ccall "&jhc_options_os" options_os :: Ptr CString +foreign import ccall "&jhc_options_arch" options_arch :: Ptr CString [clean up handling of Jhc.Options options John Meacham **20090306053012 Ignore-this: ca971f7f12bcb66e3a15cb00cbdaa794 ] hunk ./Cmm/OpEval.hs 15 import Cmm.Op import Control.Monad import Maybe +import qualified Data.Map as Map class Expression t e | e -> t where hunk ./Cmm/OpEval.hs 80 f Add v1 v2 = return $ toExpression (v1 + v2) str f Sub v1 v2 = return $ toExpression (v1 - v2) str f Mul v1 v2 = return $ toExpression (v1 * v2) str - f Eq v1 v2 = return $ toBool (v1 == v2) - f NEq v1 v2 = return $ toBool (v1 /= v2) f op v1 v2 | v2 /= 0, isJust ans = ans where ans = case op of Div -> return $ toExpression (v1 `div` v2) str hunk ./Cmm/OpEval.hs 93 f FMul v1 v2 = return $ toExpression (v1 * v2) str f FPwr v1 v2 = return $ toExpression (realToFrac (realToFrac v1 ** realToFrac v2 :: Double)) str - f op v1 v2 | Just v <- lookup op ops = return $ toBool (v1 `v` v2) where - ops = [(Lt,(<)), (Gt,(>)), (Lte,(<=)), (Gte,(>=)), - (FLt,(<)), (FGt,(>)), (FLte,(<=)), (FGte,(>=))] - f op v1 v2 | Just v <- lookup op ops, v1 >= 0 && v2 >= 0 = return $ toBool (v1 `v` v2) where - ops = [(ULt,(<)), (UGt,(>)), (ULte,(<=)), (UGte,(>=))] + f op v1 v2 | Just v <- Map.lookup op ops = return $ toBool (v1 `v` v2) where + ops = Map.fromList [(Lt,(<)), (Gt,(>)), (Lte,(<=)), (Gte,(>=)), + (FLt,(<)), (FGt,(>)), (FLte,(<=)), (FGte,(>=)), (Eq,(==)),(NEq,(/=))] + + f op v1 v2 | Just v <- Map.lookup op ops, v1 >= 0 && v2 >= 0 = return $ toBool (v1 `v` v2) where + ops = Map.fromList [(ULt,(<)), (UGt,(>)), (ULte,(<=)), (UGte,(>=))] f _ _ _ = Nothing -- we normalize ops such that constants are always on the left side binOp bop t1 t2 tr e1 e2 str | Just _ <- toConstant e2, Just bop' <- commuteBinOp bop = Just $ createBinOp bop' t2 t1 tr e2 e1 str hunk ./E/PrimOpt.hs 29 import qualified Cmm.Op as Op -{- +{-@Extensions hunk ./E/PrimOpt.hs 31 -The primitive operators provided which may be imported into code are +# Foreign Primitives hunk ./E/PrimOpt.hs 33 -'seq' - evaluate first argument to WHNF, return second one -plus/divide/minus - perform operation on primitive type -zero/one - the zero and one values for primitive types -const. - evaluates to the C constant -error. - equivalent to 'error ' -exitFailure__ - abort program immediately with no message -increment/decrement - increment or decrement a primitive numeric type by 1 +In addition to foreign imports of external functions as described in the FFI +spec. Jhc supports 'primitive' imports that let you communicate primitives directly +to the compiler. In general, these should not be used other than in the implementation +of the standard libraries. They generally do little error checking as it is assumed you +know what you are doing if you use them. All haskell visible entities are +introduced via foreign declarations in jhc. + +They all have the form + + foreign import primitive "specification" haskell_name :: type + +where "specification" is one of the following + +seq +: evaluate first argument to WHNF, then return the second argument + +zero,one +: the values zero and one of any primitive type. + +const.C_CONSTANT +: the text following const is directly inserted into the resulting C file + +peek.TYPE +: the peek primitive for raw value TYPE + +poke.TYPE +: the poke primitive for raw value TYPE + +sizeOf.TYPE, alignmentOf.TYPE, minBound.TYPE, maxBound.TYPE, umaxBound.TYPE +: various properties of a given internal type. + +error.MESSAGE +: results in an error with constant message MESSAGE. + +constPeekByte +: peek of a constant value specialized to bytes, used internally by Jhc.String + +box +: take an unboxed value and box it, the shape of the box is determined by the type at which this is imported + +unbox +: take an boxed value and unbox it, the shape of the box is determined by the type at which this is imported + +increment, decrement +: increment or decrement a numerical integral primitive value + +fincrement, fdecrement +: increment or decrement a numerical floating point primitive value + +exitFailure__ +: abort the program immediately + +C-- Primitive +: any C-- primitive may be imported in this manner. -} hunk ./E/PrimOpt.hs 91 + unbox :: DataTable -> E -> Id -> (TVr -> E) -> E unbox dataTable e vn wtd = eCase e [Alt (litCons { litName = cna, litArgs = [tvra], litType = te }) (wtd tvra)] Unknown where te = getType e hunk ./E/PrimOpt.hs 100 +-- | this creates a string representing the type of primitive optimization was +-- performed for bookkeeping purposes + cextra Op {} [] = "" cextra Op {} xs = '.':map f xs where f ELit {} = 'c' hunk ./E/PrimOpt.hs 146 fromUnOp _ = Nothing -{- - -primOpt' dataTable (EPrim (APrim s _) xs t) | Just n <- primopt s xs t = do - mtick (toAtom $ "E.PrimOpt." ++ braces (pprint s) ++ cextra s xs ) - primOpt' dataTable n where - - -- constant operations - primopt (Operator "+" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt = return $ (ELit (LitInt (l1 + l2) rt)) - primopt (Operator "-" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt = return $ (ELit (LitInt (l1 - l2) rt)) - primopt (Operator "*" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt = return $ (ELit (LitInt (l1 * l2) rt)) - primopt (Operator "==" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt = return $ if l1 == l2 then iTrue else iFalse - primopt (Operator ">=" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt = return $ if l1 >= l2 then iTrue else iFalse - primopt (Operator "<=" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt = return $ if l1 <= l2 then iTrue else iFalse - primopt (Operator ">" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt = return $ if l1 > l2 then iTrue else iFalse - primopt (Operator "<" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt = return $ if l1 < l2 then iTrue else iFalse - primopt (Operator "-" [ta] tr) [ELit (LitInt x t)] rt | ta == tr && rt == t = return $ ELit (LitInt (negate x) t) - -- compare of equals - primopt (Operator "==" [ta,tb] tr) [e1,e2] rt | e1 == e2 = return iTrue - primopt (Operator ">=" [ta,tb] tr) [e1,e2] rt | e1 == e2 = return iTrue - primopt (Operator "<=" [ta,tb] tr) [e1,e2] rt | e1 == e2 = return iTrue - primopt (Operator ">" [ta,tb] tr) [e1,e2] rt | e1 == e2 = return iFalse - primopt (Operator "<" [ta,tb] tr) [e1,e2] rt | e1 == e2 = return iFalse - -- x + 0 = x - primopt (Operator "+" [ta,tb] tr) [e1,(ELit (LitInt 0 t))] rt = return $ e1 - primopt (Operator "+" [ta,tb] tr) [(ELit (LitInt 0 t)),e1] rt = return $ e1 - -- x * 0 = 0 - primopt (Operator "*" [ta,tb] tr) [_,(ELit (LitInt 0 t))] rt = return $ (ELit (LitInt 0 t)) - primopt (Operator "*" [ta,tb] tr) [(ELit (LitInt 0 t)),_] rt = return $ (ELit (LitInt 0 t)) - -- x * 1 = x - primopt (Operator "*" [ta,tb] tr) [e1,(ELit (LitInt 1 t))] rt = return $ e1 - primopt (Operator "*" [ta,tb] tr) [(ELit (LitInt 1 t)),e1] rt = return $ e1 - -- x / 1 = x - primopt (Operator "/" [ta,tb] tr) [e1,(ELit (LitInt 1 t))] rt = return $ e1 - -- x / x = 1 - check for 0 / 0 - --primopt (Operator "/" [ta,tb] tr) [e1,e2] rt | e1 == e2 = return $ (ELit (LitInt 1 rt)) - -- 0 / x = 0 - check for 0 / 0 - --primopt (Operator "/" [ta,tb] tr) [(ELit (LitInt 0 t)),_] rt = return $ (ELit (LitInt 0 t)) - -- x - 0 = x - primopt (Operator "-" [ta,tb] tr) [e1,(ELit (LitInt 0 t))] rt = return $ e1 - -- 0 - x = -x - primopt (Operator "-" [ta,tb] tr) [(ELit (LitInt 0 t)),e1] rt = return $ EPrim (APrim (Operator "-" [ta] tr) mempty) [e1] rt - -- x << 0 = x, x >> 0 = x - primopt (Operator "<<" [ta,tb] tr) [e1,(ELit (LitInt 0 t))] rt = return $ e1 - primopt (Operator ">>" [ta,tb] tr) [e1,(ELit (LitInt 0 t))] rt = return $ e1 - -- x % 1 = 0 - primopt (Operator "%" [ta,tb] tr) [e1,(ELit (LitInt 1 t))] rt = return $ (ELit (LitInt 0 rt)) - -- x % x = 0 - check for 0 % 0 - --primopt (Operator "%" [ta,tb] tr) [e1,e2] rt | e1 == e2 = return $ (ELit (LitInt 0 rt)) - -- 0 % x = 0 - check for 0 % 0 - --primopt (Operator "%" [ta,tb] tr) [(ELit (LitInt 0 t)),_] rt = return $ (ELit (LitInt 0 t)) - -- eq to case - primopt (Operator "==" [ta,tb] tr) [e,(ELit (LitInt x t))] rt | isIntegral t = return $ eCase e [Alt (LitInt x t) iTrue ] iFalse - primopt (Operator "==" [ta,tb] tr) [(ELit (LitInt x t)),e] rt | isIntegral t = return $ eCase e [Alt (LitInt x t) iTrue ] iFalse - -- cast of constant - primopt (CCast _ _) [ELit (LitInt x _)] t = return $ ELit (LitInt x t) -- TODO ensure constant fits - primopt _ _ _ = fail "No primitive optimization to apply" -primOpt' _ x = return x --} - +-- | this is called once after conversion to E on all primitives, it performs various +-- one time only transformations. 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 hunk ./E/PrimOpt.hs 186 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 [] 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,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) hunk ./Grin/FromE.hs 414 ce (EPrim ap@(APrim (PrimPrim prim) _) as _) = f (fromAtom prim) as where - pconst s = Prim (APrim CConst { primConst = s, primRetType = "int" } mempty) [] [tIntzh] +-- pconst s = Prim (APrim CConst { primConst = s, primRetType = "int" } mempty) [] [tEnumzh] -- options hunk ./Grin/FromE.hs 417 - f "options_target" [_] = do return $ Return [toUnVal (0::Int)] - f "options_isWindows" [_] = do return $ pconst "JHC_isWindows" - f "options_isPosix" [_] = do return $ pconst "JHC_isPosix" - f "options_isBigEndian" [_] = do return $ pconst "JHC_isBigEndian" +-- f "options_target" [] = do return $ Return [Lit 0 tEnumzh] +-- f "options_isWindows" [] = do return $ pconst "JHC_isWindows" +-- f "options_isPosix" [] = do return $ pconst "JHC_isPosix" +-- f "options_isBigEndian" [] = do return $ pconst "JHC_isBigEndian" -- artificial dependencies f "newWorld__" [_] = do hunk ./Main.hs 528 (viaGhc,fn,_,_) <- determineArch wdump FD.Progress $ putStrLn $ "Arch: " ++ fn - let theTarget = ELit litCons { litName = dc_Target, litArgs = [ELit (LitInt targetIndex tEnumzh)], litType = ELit litCons { litName = tc_Target, litArgs = [], litType = eStar } } - targetIndex = if viaGhc then 1 else 0 - prog <- return $ runIdentity $ flip programMapDs prog $ \(t,e) -> return $ if tvrIdent t == toId v_target then (t { tvrInfo = setProperty prop_INLINE mempty },theTarget) else (t,e) - --wdump FD.Core $ printProgram prog prog <- if (fopts FO.TypeAnalysis) then do hunk ./data/names.txt 83 eqString Jhc.String.eqString eqUnpackedString Jhc.String.eqUnpackedString unpackString Jhc.String.unpackString -target Jhc.Options.target error Jhc.IO.error minBound Jhc.Enum.minBound maxBound Jhc.Enum.maxBound [clean up core and grin dumping some John Meacham **20090306085852 Ignore-this: e1fae5d5be893403d425df7284f0e552 ] hunk ./E/SSimplify.hs 296 so_boundVarsCache :: IdSet, so_cachedScope :: Env } - {- derive: Monoid -} emptySimplifyOpts = SimpOpts { so_noInlining = False , so_finalPhase = False hunk ./FlagDump.flags 62 !Grin code tags list of all tags and their types +steps show interpreter go +grin dump all grin to the screen + grin-preeval show grin code just before eval/apply inlining grin-posteval show grin code just before eval/apply inlining hunk ./FlagDump.flags 67 -grin show final grin code grin-initial grin right after conversion from core grin-normalized grin right after first normalization hunk ./FlagDump.flags 69 -steps show interpreter go -eval show detailed eval inlining info grin-pass show each iteration of code while transforming grin-steps show what happens in each transformation grin-graph print dot file of final grin code to outputname_grin.dot hunk ./FlagDump.flags 72 +grin-final final grin before conversion to C + !General @verbose progress hunk ./Main.hs 622 --compileToHs prog exitSuccess - wdump FD.CoreBeforelift $ printProgram prog + wdump FD.CoreBeforelift $ dumpCore "before-lift" prog prog <- transformProgram transformParms { transformCategory = "LambdaLift", transformDumpProgress = dump FD.Progress, transformOperation = lambdaLift } prog hunk ./Main.hs 625 - wdump FD.CoreAfterlift $ printProgram prog + wdump FD.CoreAfterlift $ dumpCore "after-lift" prog + finalStats <- Stats.new hunk ./Main.hs 699 stats <- Stats.new progress "Converting to Grin..." prog <- return $ atomizeApps True prog - wdump FD.CoreMangled $ printProgram prog + --wdump FD.CoreMangled $ printProgram prog + wdump FD.CoreMangled $ dumpCore "mangled" prog x <- Grin.FromE.compile prog when verbose $ Stats.print "Grin" Stats.theStats wdump FD.GrinInitial $ do dumpGrin "initial" x hunk ./Main.hs 770 let dot = graphGrin grin fn = optOutName options writeFile (fn ++ "_grin.dot") dot - dumpGrin "final" grin + wdump FD.GrinFinal $ dumpGrin "final" grin [add back in an optimization step after lambda lifting to fix up some core that translates to pessismal grin John Meacham **20090306085922 Ignore-this: 56b7583559da590ff18a5f46070c8d00 ] hunk ./E/SSimplify.hs 290 data SimplifyOpts = SimpOpts { so_noInlining :: Bool, -- ^ this inhibits all inlining inside functions which will always be inlined so_finalPhase :: Bool, -- ^ no rules and don't inhibit inlining + so_postLift :: Bool, -- ^ don't inline anything that was lifted out so_boundVars :: IdMap Comb, -- ^ bound variables so_forwardVars :: IdSet, -- ^ variables that we know will exist, but might not yet. hunk ./E/SSimplify.hs 302 , so_finalPhase = False , so_boundVars = mempty , so_forwardVars = mempty + , so_postLift = False , so_boundVarsCache = mempty , so_cachedScope = mempty } hunk ./E/SSimplify.hs 848 let (ne,nn) = runRename used (foldl EAp z zs) smAddNamesIdSet nn return ne + appVar v xs | so_postLift sopts = app (EVar v,xs) appVar v xs = do me <- etaExpandAp (progDataTable prog) v xs case me of hunk ./E/SSimplify.hs 880 t' <- nname t case Info.lookup (tvrInfo t) of _ | forceNoinline t -> return (tvrIdent t,noUseInfo { useOccurance = LoopBreaker },t',e) + | so_postLift sopts && (isELam e || isECase e) -> return (tvrIdent t,noUseInfo { useOccurance = LoopBreaker },t',e) Just ui@UseInfo { useOccurance = Once } -> return (tvrIdent t,ui,error $ "Once: " ++ show t,e) Just n -> return (tvrIdent t,n,t',e) -- We don't want to inline things we don't have occurance info for because they might lead to an infinite loop. hopefully the next pass will fix it. hunk ./E/SSimplify.hs 913 Just (UseInfo { minimumArgs = min }) -> min Nothing -> 0 - ds' <- sequence [ etaExpandDef' (progDataTable prog) (minArgs t) t e | (t,e) <- ds'] + ds' <- if so_postLift sopts then return ds' else sequence [ etaExpandDef' (progDataTable prog) (minArgs t) t e | (t,e) <- ds'] return (ds',inb') hunk ./Grin/FromE.hs 532 (_,_) | otherwise -> do as <- mapM cp as def <- createDef d newNodeVar - return $ e :>>= [toVal b] :-> Case v (as ++ def) + return $ e :>>= [toVal b] :-> Case (toVal b) (as ++ def) ce e = error $ render (text "Grin.FromE.compile'.ce in function:" <+> pprint funcName <$> text "can't grok expression:" <+> pprint e) hunk ./Main.hs 644 wdump FD.Progress $ printEStats (programE prog) + prog <- simplifyProgram SS.emptySimplifyOpts { SS.so_postLift = True, SS.so_finalPhase = True } "PostLiftSimplify" verbose prog +-- prog <- programFloatInward prog + when collectPassStats $ do Stats.print "PassStats" Stats.theStats Stats.clear Stats.theStats [minor improvements John Meacham **20090306103607 Ignore-this: 7a317625312dca537d85c025ffaf82d ] hunk ./Main.hs 644 wdump FD.Progress $ printEStats (programE prog) + prog <- Demand.analyzeProgram prog + prog <- return $ E.CPR.cprAnalyzeProgram prog prog <- simplifyProgram SS.emptySimplifyOpts { SS.so_postLift = True, SS.so_finalPhase = True } "PostLiftSimplify" verbose prog -- prog <- programFloatInward prog hunk ./lib/base/Numeric.hs 208 Just dec -> let dec' = max dec 1 in case is of - [] -> '0':'.':take dec' (repeat '0') ++ "e0" + [] -> '0':'.':replicate dec' '0' ++ "e0" _ -> let (ei, is') = roundTo base (dec'+1) is d:ds = map intToDigit hunk ./lib/base/Prelude.hs 415 {-# RULES "foldr/zip" forall k z xs ys . foldr k z (zip xs ys) = let zip' (a:as) (b:bs) = k (a,b) (zip' as bs); zip' _ _ = z in zip' xs ys #-} -- {-# RULES "foldr/sequence" forall k z xs . foldr k z (sequence xs) = foldr (\x y -> do rx <- x; ry <- y; return (k rx ry)) (return z) xs #-} -- {-# RULES "foldr/mapM" forall k z f xs . foldr k z (mapM f xs) = foldr (\x y -> do rx <- f x; ry <- y; return (k rx ry)) (return z) xs #-} +{-# RULES "take/repeat" forall n x . take n (repeat x) = replicate n x #-} default(Int,Double) Context: [update datestamp John Meacham **20090305020802 Ignore-this: a965837fa133f37c12745947b0d90051 ] [TAG neopdoxhedvo John Meacham **20090305020739 Ignore-this: 97bfe302a3ba14a8aeef90b60ebd03ed ] Patch bundle hash: f9a4265f83a2bfdf0d666551afa79ffe413a42b4