From 844e0d6d6c012647851b55b0601021650604f46e Mon Sep 17 00:00:00 2001 From: Tim Chevalier Date: Fri, 12 Sep 2008 03:22:19 +0000 Subject: [PATCH] ext-core library: Export a lot more things from Prims See comments for details. --- utils/ext-core/Language/Core/Overrides.hs | 7 ++- utils/ext-core/Language/Core/Prims.hs | 94 ++++++++++++++++++++++++----- 2 files changed, 84 insertions(+), 17 deletions(-) diff --git a/utils/ext-core/Language/Core/Overrides.hs b/utils/ext-core/Language/Core/Overrides.hs index a545a25..391b129 100644 --- a/utils/ext-core/Language/Core/Overrides.hs +++ b/utils/ext-core/Language/Core/Overrides.hs @@ -16,7 +16,6 @@ module Language.Core.Overrides (override) where import Language.Core.Core import Language.Core.Encoding import Language.Core.ParsecParser -import Language.Core.Prims import Data.Generics import System.FilePath @@ -57,16 +56,20 @@ wiredInFileName (M (_,_,leafName)) = mungePackageName :: Module -> Module -- for now: just substitute "base-extcore" for "base" -- and "GHC" for "GHC_ExtCore" in every module name -mungePackageName m@(Module mn _ _) = everywhere (mkT mungeMname) +mungePackageName m@(Module _ _ _) = everywhere (mkT mungeMname) (everywhere (mkT mungePname) (everywhere (mkT mungeVarName) m)) where mungePname (P s) | s == zEncodeString overriddenPname = (P "base") mungePname p = p +{- TODO: Commented out because this code should eventually + be completely rewritten. No time to do it now. -- rewrite uses of fake primops mungeVarName (Var (Just mn', v)) | mn' == mn && v `elem` (fst (unzip newPrimVars)) = Var (Just primMname, v) +-} + mungeVarName :: Exp -> Exp mungeVarName e = e mungeMname :: AnMname -> AnMname diff --git a/utils/ext-core/Language/Core/Prims.hs b/utils/ext-core/Language/Core/Prims.hs index a022f42..181977b 100644 --- a/utils/ext-core/Language/Core/Prims.hs +++ b/utils/ext-core/Language/Core/Prims.hs @@ -4,7 +4,13 @@ Most are defined in PrimEnv, which is automatically generated from GHC's primops.txt. -} -module Language.Core.Prims(initialEnv, primEnv, newPrimVars) where +module Language.Core.Prims(initialEnv, primEnv, primId, bv, + tIntzh, tInt64zh, tCharzh, tFloatzh, tAddrzh, tDoublezh, tcStatezh, + tWordzh, tWord64zh, tByteArrayzh, + tcStablePtrzh, tcIO, mkInitialEnv, mkTypeEnv, tRWS, tBool, + ioBaseMname) where + +import Control.Monad import Language.Core.Core import Language.Core.Encoding @@ -15,26 +21,43 @@ import Language.Core.PrimEnv initialEnv :: Menv initialEnv = efromlist [(primMname,primEnv), - (errMname,errorEnv)] + (errMname,errorEnv), + (boolMname,boolEnv)] primEnv :: Envs -primEnv = Envs {tcenv_=efromlist $ map (\ (t,k) -> (t,Kind k)) +-- Tediously, we add defs for ByteArray# etc. because these are +-- declared as ByteArr# (etc.) in primops.txt, and GHC has +-- ByteArray# etc. wired-in. +-- At least this is better than when all primops were wired-in here. +primEnv = Envs {tcenv_=efromlist $ map (\ (t,k) -> (t,Kind k)) $ + [(snd tcByteArrayzh,ktByteArrayzh), + (snd tcMutableArrayzh, ktMutableArrayzh), + (snd tcMutableByteArrayzh, ktMutableByteArrayzh)] ++ ([(snd $ tcUtuple n, ktUtuple n) | n <- [1..maxUtuple]] ++ ((snd tcArrow,ktArrow):primTcs)), cenv_=efromlist primDcs, - venv_=efromlist (newPrimVars ++ opsState ++ primVals)} + venv_=efromlist (opsState ++ primVals)} errorEnv :: Envs errorEnv = Envs {tcenv_=eempty, cenv_=eempty, venv_=efromlist errorVals} - -newPrimVars :: [(Id, Ty)] -newPrimVars = map (\ (v, ty) -> (zEncodeString v, ty)) - [("hPutChar#", mkFunTy tIntzh (mkFunTy tCharzh tIOUnit)), - ("isSpace#", mkFunTy tCharzh tBool)] - +-- Unpleasantly, we wire in the Bool type because some people +-- (i.e. me) need to depend on it being primitive. This shouldn't +-- hurt anything, since if someone pulls in the GHC.Bool module, +-- it will override this definition. +boolEnv :: Envs +boolEnv = Envs {tcenv_=efromlist boolTcs, + cenv_=efromlist boolDcs, + venv_=eempty} + +boolTcs :: [(Tcon, KindOrCoercion)] +boolTcs = [(snd tcBool, Kind Klifted)] + +boolDcs :: [(Dcon, Ty)] +boolDcs = [(dcTrue, tBool), + (dcFalse, tBool)] primDcs :: [(Dcon,Ty)] primDcs = map (\ ((_,c),t) -> (c,t)) @@ -47,6 +70,20 @@ opsState :: [(Var, Ty)] opsState = [ ("realWorldzh", tRWS)] +{- Arrays -} + +tcByteArrayzh, tcMutableArrayzh, tcMutableByteArrayzh :: Qual Tcon +ktByteArrayzh, ktMutableArrayzh, ktMutableByteArrayzh :: Kind + +tcByteArrayzh = pvz "ByteArray" +ktByteArrayzh = Kunlifted + +tcMutableArrayzh = pvz "MutableArray" +ktMutableArrayzh = Karrow Klifted (Karrow Klifted Kunlifted) + +tcMutableByteArrayzh = pvz "MutableByteArray" +ktMutableByteArrayzh = Karrow Klifted Kunlifted + {- Real world and state. -} -- tjc: why isn't this one unboxed? @@ -79,7 +116,9 @@ str2A = Tforall ("a",Kopen) (tArrow tAddrzh (Tvar "a")) forallAA = Tforall ("a",Kopen) (Tvar "a") tBool :: Ty -tBool = Tcon (Just boolMname, "Bool") +tBool = Tcon tcBool +tcBool :: Qual Tcon +tcBool = (Just boolMname, "Bool") tcChar :: Qual Tcon tcChar = bv "Char" tChar :: Ty @@ -90,11 +129,36 @@ tList :: Ty -> Ty tList t = Tapp (Tcon tcList) t tString :: Ty tString = tList tChar -tIntzh, tCharzh, tIOUnit :: Ty +tIntzh, tInt64zh, tWordzh, tWord64zh, tCharzh, tFloatzh, tDoublezh, {-tIOUnit,-} + tByteArrayzh :: Ty tIntzh = Tcon (primId "Int#") +tInt64zh = Tcon (primId "Int64#") +tWordzh = Tcon (primId "Word#") +tWord64zh = Tcon (primId "Word64#") +tByteArrayzh = Tcon (primId "ByteArray#") tCharzh = Tcon (primId "Char#") -tIOUnit = Tapp (Tcon (Just (mkBaseMname "IOBase"), "IO")) - (Tcon (bv "Z0T")) +tFloatzh = Tcon (primId "Float#") +tDoublezh = Tcon (primId "Double#") +tcStablePtrzh, tcIO :: Qual Tcon +tcStablePtrzh = pvz "StablePtr" +tcIO = (Just (mkBaseMname "IOBase"), "IO") primId :: String -> Qual Id -primId = pv . zEncodeString \ No newline at end of file +primId = pv . zEncodeString + +--- doesn't really belong here... sigh + +mkInitialEnv :: [Module] -> IO Menv +mkInitialEnv libs = foldM mkTypeEnv initialEnv libs + +mkTypeEnv :: Menv -> Module -> IO Menv +mkTypeEnv globalEnv m@(Module mn _ _) = + catch (return (envsModule globalEnv m)) handler + where handler e = do + putStrLn ("WARNING: mkTypeEnv caught an exception " ++ show e + ++ " while processing " ++ show mn) + return globalEnv + +----- move this +ioBaseMname :: AnMname +ioBaseMname = mkBaseMname "IOBase" -- 1.7.10.4