X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fext-core%2FLanguage%2FCore%2FPrims.hs;h=69e0cb967805ae4ef7b1eb02ae06768a0d8ad13d;hb=5a4c6ef6e909fbd978ff81bb3453489e884d1885;hp=0c682d4da2e11ac01f6391f5f1271e79fe7f0edd;hpb=b84b5969798530dbf5be9b8bb795b77e5dfbf042;p=ghc-hetmet.git

diff --git a/utils/ext-core/Language/Core/Prims.hs b/utils/ext-core/Language/Core/Prims.hs
index 0c682d4..69e0cb9 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, tcBool,
+             ioBaseMname) where
+
+import Control.Monad
 
 import Language.Core.Core
 import Language.Core.Encoding
@@ -15,7 +21,8 @@ import Language.Core.PrimEnv
 
 initialEnv :: Menv
 initialEnv = efromlist [(primMname,primEnv),
-		     (errMname,errorEnv)]
+		     (errMname,errorEnv),
+                     (boolMname,boolEnv)]
 
 primEnv :: Envs
 -- Tediously, we add defs for ByteArray# etc. because these are
@@ -29,19 +36,28 @@ primEnv = Envs {tcenv_=efromlist $ map (\ (t,k) -> (t,Kind k)) $
                  ([(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))
@@ -83,12 +99,15 @@ tStatezh t = Tapp (Tcon tcStatezh) t
 
 {- Properly defined in PrelError, but needed in many modules before that. -}
 errorVals :: [(Var, Ty)]
-errorVals = [
+errorVals = []
+{-
+ [
  ("error", Tforall ("a",Kopen) (tArrow tString (Tvar "a"))),
  ("irrefutPatError", str2A),
  ("patError", str2A),
  ("divZZeroError", forallAA),
  ("overflowError", forallAA)]
+-}
 
 {- Non-primitive, but mentioned in the types of primitives. -}
 
@@ -100,7 +119,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
@@ -111,11 +132,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"