-{- This module really should be auto-generated from the master primops.txt file.
- It is roughly correct (but may be slightly incomplete) wrt/ GHC5.02. -}
+{-# OPTIONS -Wall #-}
-module Prims where
+{- This module contains a few primitive types that need to be wired in.
+ Most are defined in PrimEnv, which is automatically generated from
+ GHC's primops.txt. -}
+
+module Prims(initialEnv, primEnv, newPrimVars) where
import Core
+import Encoding
import Env
import Check
+import PrimCoercions
+
+import PrimEnv
initialEnv :: Menv
initialEnv = efromlist [(primMname,primEnv),
- ("PrelErr",errorEnv)]
+ (errMname,errorEnv)]
primEnv :: Envs
-primEnv = Envs {tcenv_=efromlist primTcs,
- tsenv_=eempty,
+-- 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 primVals}
+ venv_=efromlist (newPrimVars ++ opsState ++ primVals)}
errorEnv :: Envs
errorEnv = Envs {tcenv_=eempty,
- tsenv_=eempty,
cenv_=eempty,
venv_=efromlist errorVals}
-{- Components of static environment -}
-primTcs :: [(Tcon,Kind)]
-primTcs =
- map (\ ((m,tc),k) -> (tc,k))
- ([(tcArrow,ktArrow),
- (tcAddrzh,ktAddrzh),
- (tcCharzh,ktCharzh),
- (tcDoublezh,ktDoublezh),
- (tcFloatzh,ktFloatzh),
- (tcIntzh,ktIntzh),
- (tcInt32zh,ktInt32zh),
- (tcInt64zh,ktInt64zh),
- (tcWordzh,ktWordzh),
- (tcWord32zh,ktWord32zh),
- (tcWord64zh,ktWord64zh),
- (tcRealWorld, ktRealWorld),
- (tcStatezh, ktStatezh),
- (tcArrayzh,ktArrayzh),
- (tcByteArrayzh,ktByteArrayzh),
- (tcMutableArrayzh,ktMutableArrayzh),
- (tcMutableByteArrayzh,ktMutableByteArrayzh),
- (tcMutVarzh,ktMutVarzh),
- (tcMVarzh,ktMVarzh),
- (tcWeakzh,ktWeakzh),
- (tcForeignObjzh, ktForeignObjzh),
- (tcStablePtrzh, ktStablePtrzh),
- (tcThreadIdzh, ktThreadIdzh),
- (tcZCTCCallable, ktZCTCCallable),
- (tcZCTCReturnable, ktZCTCReturnable)]
- ++ [(tcUtuple n, ktUtuple n) | n <- [1..maxUtuple]])
+newPrimVars :: [(Id, Ty)]
+newPrimVars = map (\ (v, ty) -> (zEncodeString v, ty))
+ [("hPutChar#", mkFunTy tIntzh (mkFunTy tCharzh tIOUnit)),
+ ("isSpace#", mkFunTy tCharzh tBool)]
primDcs :: [(Dcon,Ty)]
-primDcs = map (\ ((m,c),t) -> (c,t))
+primDcs = map (\ ((_,c),t) -> (c,t))
[(dcUtuple n, dcUtupleTy n) | n <- [1..maxUtuple]]
-primVals :: [(Var,Ty)]
-primVals =
- opsAddrzh ++
- opsCharzh ++
- opsDoublezh ++
- opsFloatzh ++
- opsIntzh ++
- opsInt32zh ++
- opsInt64zh ++
- opsIntegerzh ++
- opsWordzh ++
- opsWord32zh ++
- opsWord64zh ++
- opsSized ++
- opsArray ++
- opsMutVarzh ++
- opsState ++
- opsExn ++
- opsMVar ++
- opsWeak ++
- opsForeignObjzh ++
- opsStablePtrzh ++
- opsConc ++
- opsMisc
-
-
-dcUtuples :: [(Qual Dcon,Ty)]
-dcUtuples = map ( \n -> (dcUtuple n, typ n)) [1..100]
- where typ n = foldr ( \tv t -> Tforall (tv,Kopen) t)
- (foldr ( \tv t -> tArrow (Tvar tv) t)
- (tUtuple (map Tvar tvs)) tvs) tvs
- where tvs = map ( \i -> ("a" ++ (show i))) [1..n]
-
-
-{- Addrzh -}
-
-tcAddrzh = (primMname,"Addrzh")
-tAddrzh = Tcon tcAddrzh
-ktAddrzh = Kunlifted
-
-opsAddrzh = [
- ("gtAddrzh",tcompare tAddrzh),
- ("geAddrzh",tcompare tAddrzh),
- ("eqAddrzh",tcompare tAddrzh),
- ("neAddrzh",tcompare tAddrzh),
- ("ltAddrzh",tcompare tAddrzh),
- ("leAddrzh",tcompare tAddrzh),
- ("nullAddrzh", tAddrzh),
- ("plusAddrzh", tArrow tAddrzh (tArrow tIntzh tAddrzh)),
- ("minusAddrzh", tArrow tAddrzh (tArrow tAddrzh tIntzh)),
- ("remAddrzh", tArrow tAddrzh (tArrow tIntzh tIntzh))]
-
-{- Charzh -}
-
-tcCharzh = (primMname,"Charzh")
-tCharzh = Tcon tcCharzh
-ktCharzh = Kunlifted
-
-opsCharzh = [
- ("gtCharzh", tcompare tCharzh),
- ("geCharzh", tcompare tCharzh),
- ("eqCharzh", tcompare tCharzh),
- ("neCharzh", tcompare tCharzh),
- ("ltCharzh", tcompare tCharzh),
- ("leCharzh", tcompare tCharzh),
- ("ordzh", tArrow tCharzh tIntzh)]
-
-
-{- Doublezh -}
-
-tcDoublezh = (primMname, "Doublezh")
-tDoublezh = Tcon tcDoublezh
-ktDoublezh = Kunlifted
-
-opsDoublezh = [
- ("zgzhzh", tcompare tDoublezh),
- ("zgzezhzh", tcompare tDoublezh),
- ("zezezhzh", tcompare tDoublezh),
- ("zszezhzh", tcompare tDoublezh),
- ("zlzhzh", tcompare tDoublezh),
- ("zlzezhzh", tcompare tDoublezh),
- ("zpzhzh", tdyadic tDoublezh),
- ("zmzhzh", tdyadic tDoublezh),
- ("ztzhzh", tdyadic tDoublezh),
- ("zszhzh", tdyadic tDoublezh),
- ("negateDoublezh", tmonadic tDoublezh),
- ("double2Intzh", tArrow tDoublezh tIntzh),
- ("double2Floatzh", tArrow tDoublezh tFloatzh),
- ("expDoublezh", tmonadic tDoublezh),
- ("logDoublezh", tmonadic tDoublezh),
- ("sqrtDoublezh", tmonadic tDoublezh),
- ("sinDoublezh", tmonadic tDoublezh),
- ("cosDoublezh", tmonadic tDoublezh),
- ("tanDoublezh", tmonadic tDoublezh),
- ("asinDoublezh", tmonadic tDoublezh),
- ("acosDoublezh", tmonadic tDoublezh),
- ("atanDoublezh", tmonadic tDoublezh),
- ("sinhDoublezh", tmonadic tDoublezh),
- ("coshDoublezh", tmonadic tDoublezh),
- ("tanhDoublezh", tmonadic tDoublezh),
- ("ztztzhzh", tdyadic tDoublezh),
- ("decodeDoublezh", tArrow tDoublezh (tUtuple[tIntzh,tIntzh,tByteArrayzh]))]
-
-
-{- Floatzh -}
-
-tcFloatzh = (primMname, "Floatzh")
-tFloatzh = Tcon tcFloatzh
-ktFloatzh = Kunlifted
-
-opsFloatzh = [
- ("gtFloatzh", tcompare tFloatzh),
- ("geFloatzh", tcompare tFloatzh),
- ("eqFloatzh", tcompare tFloatzh),
- ("neFloatzh", tcompare tFloatzh),
- ("ltFloatzh", tcompare tFloatzh),
- ("leFloatzh", tcompare tFloatzh),
- ("plusFloatzh", tdyadic tFloatzh),
- ("minusFloatzh", tdyadic tFloatzh),
- ("timesFloatzh", tdyadic tFloatzh),
- ("divideFloatzh", tdyadic tFloatzh),
- ("negateFloatzh", tmonadic tFloatzh),
- ("float2Intzh", tArrow tFloatzh tIntzh),
- ("expFloatzh", tmonadic tFloatzh),
- ("logFloatzh", tmonadic tFloatzh),
- ("sqrtFloatzh", tmonadic tFloatzh),
- ("sinFloatzh", tmonadic tFloatzh),
- ("cosFloatzh", tmonadic tFloatzh),
- ("tanFloatzh", tmonadic tFloatzh),
- ("asinFloatzh", tmonadic tFloatzh),
- ("acosFloatzh", tmonadic tFloatzh),
- ("atanFloatzh", tmonadic tFloatzh),
- ("sinhFloatzh", tmonadic tFloatzh),
- ("coshFloatzh", tmonadic tFloatzh),
- ("tanhFloatzh", tmonadic tFloatzh),
- ("powerFloatzh", tdyadic tFloatzh),
- ("float2Doublezh", tArrow tFloatzh tDoublezh),
- ("decodeFloatzh", tArrow tFloatzh (tUtuple[tIntzh,tIntzh,tByteArrayzh]))]
-
-
-{- Intzh -}
-
-tcIntzh = (primMname,"Intzh")
-tIntzh = Tcon tcIntzh
-ktIntzh = Kunlifted
-
-opsIntzh = [
- ("zpzh", tdyadic tIntzh),
- ("zmzh", tdyadic tIntzh),
- ("ztzh", tdyadic tIntzh),
- ("quotIntzh", tdyadic tIntzh),
- ("remIntzh", tdyadic tIntzh),
- ("gcdIntzh", tdyadic tIntzh),
- ("negateIntzh", tmonadic tIntzh),
- ("addIntCzh", tArrow tIntzh (tArrow tIntzh (tUtuple [tIntzh, tIntzh]))),
- ("subIntCzh", tArrow tIntzh (tArrow tIntzh (tUtuple [tIntzh, tIntzh]))),
- ("mulIntCzh", tArrow tIntzh (tArrow tIntzh (tUtuple [tIntzh, tIntzh]))),
- ("zgzh", tcompare tIntzh),
- ("zgzezh", tcompare tIntzh),
- ("zezezh", tcompare tIntzh),
- ("zszezh", tcompare tIntzh),
- ("zlzh", tcompare tIntzh),
- ("zlzezh", tcompare tIntzh),
- ("chrzh", tArrow tIntzh tCharzh),
- ("int2Wordzh", tArrow tIntzh tWordzh),
- ("int2Floatzh", tArrow tIntzh tFloatzh),
- ("int2Doublezh", tArrow tIntzh tDoublezh),
- ("intToInt32zh", tArrow tIntzh tInt32zh),
- ("int2Integerzh", tArrow tIntzh tIntegerzhRes),
- ("iShiftLzh", tdyadic tIntzh),
- ("iShiftRAzh", tdyadic tIntzh),
- ("iShiftRLh", tdyadic tIntzh)]
-
-
-{- Int32zh -}
-
-tcInt32zh = (primMname,"Int32zh")
-tInt32zh = Tcon tcInt32zh
-ktInt32zh = Kunlifted
-
-opsInt32zh = [
- ("int32ToIntzh", tArrow tInt32zh tIntzh),
- ("int32ToIntegerzh", tArrow tInt32zh tIntegerzhRes)]
-
-
-{- Int64zh -}
-
-tcInt64zh = (primMname,"Int64zh")
-tInt64zh = Tcon tcInt64zh
-ktInt64zh = Kunlifted
-
-opsInt64zh = [
- ("int64ToIntegerzh", tArrow tInt64zh tIntegerzhRes)]
-
-{- Integerzh -}
-
--- not actuallly a primitive type
-tIntegerzhRes = tUtuple [tIntzh, tByteArrayzh]
-tIntegerzhTo t = tArrow tIntzh (tArrow tByteArrayzh t)
-tdyadicIntegerzh = tIntegerzhTo (tIntegerzhTo tIntegerzhRes)
-
-opsIntegerzh = [
- ("plusIntegerzh", tdyadicIntegerzh),
- ("minusIntegerzh", tdyadicIntegerzh),
- ("timesIntegerzh", tdyadicIntegerzh),
- ("gcdIntegerzh", tdyadicIntegerzh),
- ("gcdIntegerIntzh", tIntegerzhTo (tArrow tIntzh tIntzh)),
- ("divExactIntegerzh", tdyadicIntegerzh),
- ("quotIntegerzh", tdyadicIntegerzh),
- ("remIntegerzh", tdyadicIntegerzh),
- ("cmpIntegerzh", tIntegerzhTo (tIntegerzhTo tIntzh)),
- ("cmpIntegerIntzh", tIntegerzhTo (tArrow tIntzh tIntzh)),
- ("quotRemIntegerzh", tIntegerzhTo (tIntegerzhTo (tUtuple [tIntzh,tByteArrayzh,tIntzh,tByteArrayzh]))),
- ("divModIntegerzh", tIntegerzhTo (tIntegerzhTo (tUtuple [tIntzh,tByteArrayzh,tIntzh,tByteArrayzh]))),
- ("integer2Intzh", tIntegerzhTo tIntzh),
- ("integer2Wordzh", tIntegerzhTo tWordzh),
- ("integerToInt32zh", tIntegerzhTo tInt32zh),
- ("integerToWord32zh", tIntegerzhTo tWord32zh),
- ("integerToInt64zh", tIntegerzhTo tInt64zh),
- ("integerToWord64zh", tIntegerzhTo tWord64zh),
- ("andIntegerzh", tdyadicIntegerzh),
- ("orIntegerzh", tdyadicIntegerzh),
- ("xorIntegerzh", tdyadicIntegerzh),
- ("complementIntegerzh", tIntegerzhTo tIntegerzhRes)]
-
-
-
-{- Wordzh -}
-
-tcWordzh = (primMname,"Wordzh")
-tWordzh = Tcon tcWordzh
-ktWordzh = Kunlifted
-
-opsWordzh = [
- ("plusWordzh", tdyadic tWordzh),
- ("minusWordzh", tdyadic tWordzh),
- ("timesWordzh", tdyadic tWordzh),
- ("quotWordzh", tdyadic tWordzh),
- ("remWordzh", tdyadic tWordzh),
- ("andzh", tdyadic tWordzh),
- ("orzh", tdyadic tWordzh),
- ("xorzh", tdyadic tWordzh),
- ("notzh", tmonadic tWordzh),
- ("shiftLzh", tArrow tWordzh (tArrow tIntzh tWordzh)),
- ("shiftRLzh", tArrow tWordzh (tArrow tIntzh tWordzh)),
- ("word2Intzh", tArrow tWordzh tIntzh),
- ("wordToWord32zh", tArrow tWordzh tWord32zh),
- ("word2Integerzh", tArrow tWordzh tIntegerzhRes),
- ("gtWordzh", tcompare tWordzh),
- ("geWordzh", tcompare tWordzh),
- ("eqWordzh", tcompare tWordzh),
- ("neWordzh", tcompare tWordzh),
- ("ltWordzh", tcompare tWordzh),
- ("leWordzh", tcompare tWordzh)]
-
-{- Word32zh -}
-
-tcWord32zh = (primMname,"Word32zh")
-tWord32zh = Tcon tcWord32zh
-ktWord32zh = Kunlifted
-
-opsWord32zh = [
- ("word32ToWordzh", tArrow tWord32zh tWordzh),
- ("word32ToIntegerzh", tArrow tWord32zh tIntegerzhRes)]
-
-{- Word64zh -}
-
-tcWord64zh = (primMname,"Word64zh")
-tWord64zh = Tcon tcWord64zh
-ktWord64zh = Kunlifted
-
-opsWord64zh = [
- ("word64ToIntegerzh", tArrow tWord64zh tIntegerzhRes)]
-
-{- Explicitly sized Intzh and Wordzh -}
+tRWS :: Ty
+tRWS = tStatezh tRealWorld
-opsSized = [
- ("narrow8Intzh", tmonadic tIntzh),
- ("narrow16Intzh", tmonadic tIntzh),
- ("narrow32Intzh", tmonadic tIntzh),
- ("narrow8Wordzh", tmonadic tWordzh),
- ("narrow16Wordzh", tmonadic tWordzh),
- ("narrow32Wordzh", tmonadic tWordzh)]
+opsState :: [(Var, Ty)]
+opsState = [
+ ("realWorldzh", tRWS)]
{- Arrays -}
-tcArrayzh = (primMname,"Arrayzh")
-tArrayzh t = Tapp (Tcon tcArrayzh) t
-ktArrayzh = Karrow Klifted Kunlifted
+tcByteArrayzh, tcMutableArrayzh, tcMutableByteArrayzh :: Qual Tcon
+ktByteArrayzh, ktMutableArrayzh, ktMutableByteArrayzh :: Kind
-tcByteArrayzh = (primMname,"ByteArrayzh")
-tByteArrayzh = Tcon tcByteArrayzh
+tcByteArrayzh = pvz "ByteArray"
ktByteArrayzh = Kunlifted
-tcMutableArrayzh = (primMname,"MutableArrayzh")
-tMutableArrayzh s t = Tapp (Tapp (Tcon tcMutableArrayzh) s) t
+tcMutableArrayzh = pvz "MutableArray"
ktMutableArrayzh = Karrow Klifted (Karrow Klifted Kunlifted)
-tcMutableByteArrayzh = (primMname,"MutableByteArrayzh")
-tMutableByteArrayzh s = Tapp (Tcon tcMutableByteArrayzh) s
+tcMutableByteArrayzh = pvz "MutableByteArray"
ktMutableByteArrayzh = Karrow Klifted Kunlifted
-opsArray = [
- ("newArrayzh", Tforall ("a",Klifted)
- (Tforall ("s",Klifted)
- (tArrow tIntzh
- (tArrow (Tvar "a")
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),tMutableArrayzh (Tvar "s") (Tvar "a")])))))),
- ("newByteArrayzh", Tforall ("s",Klifted)
- (tArrow tIntzh
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),tMutableByteArrayzh (Tvar "s")])))),
- ("newPinnedByteArrayzh", Tforall ("s",Klifted)
- (tArrow tIntzh
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),tMutableByteArrayzh (Tvar "s")])))),
- ("byteArrayContentszh", tArrow tByteArrayzh tAddrzh),
- ("indexCharArrayzh", tArrow tByteArrayzh (tArrow tIntzh tCharzh)),
- ("indexWideCharArrayzh", tArrow tByteArrayzh (tArrow tIntzh tCharzh)),
- ("indexIntArrayzh", tArrow tByteArrayzh (tArrow tIntzh tIntzh)),
- ("indexWordArrayzh", tArrow tByteArrayzh (tArrow tIntzh tWordzh)),
- ("indexAddrArrayzh", tArrow tByteArrayzh (tArrow tIntzh tAddrzh)),
- ("indexFloatArrayzh", tArrow tByteArrayzh (tArrow tIntzh tFloatzh)),
- ("indexDoubleArrayzh", tArrow tByteArrayzh (tArrow tIntzh tDoublezh)),
- ("indexStablePtrArrayzh", Tforall ("a",Klifted) (tArrow tByteArrayzh (tArrow tIntzh (tStablePtrzh (Tvar "a"))))),
- ("indexInt8Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tIntzh)),
- ("indexInt16Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tIntzh)),
- ("indexInt32Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tInt32zh)),
- ("indexInt64Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tInt64zh)),
- ("indexWord8Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tWordzh)),
- ("indexWord16Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tWordzh)),
- ("indexWord32Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tWord32zh)),
- ("indexWord64Arrayzh", tArrow tByteArrayzh (tArrow tIntzh tWord64zh)),
- ("readCharArrayzh", tReadMutableByteArrayzh tCharzh),
- ("readWideCharArrayzh", tReadMutableByteArrayzh tCharzh),
- ("readIntArrayzh", tReadMutableByteArrayzh tIntzh),
- ("readWordArrayzh", tReadMutableByteArrayzh tWordzh),
- ("readAddrArrayzh", tReadMutableByteArrayzh tAddrzh),
- ("readFloatArrayzh", tReadMutableByteArrayzh tFloatzh),
- ("readDoubleArrayzh", tReadMutableByteArrayzh tDoublezh),
- ("readStablePtrArrayzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutableByteArrayzh (Tvar "s"))
- (tArrow tIntzh
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),tStablePtrzh (Tvar "a")])))))),
- ("readInt8Arrayzh", tReadMutableByteArrayzh tIntzh),
- ("readInt16Arrayzh", tReadMutableByteArrayzh tIntzh),
- ("readInt32Arrayzh", tReadMutableByteArrayzh tInt32zh),
- ("readInt64Arrayzh", tReadMutableByteArrayzh tInt64zh),
- ("readWord8Arrayzh", tReadMutableByteArrayzh tWordzh),
- ("readWord16Arrayzh", tReadMutableByteArrayzh tWordzh),
- ("readWord32Arrayzh", tReadMutableByteArrayzh tWord32zh),
- ("readWord64Arrayzh", tReadMutableByteArrayzh tWord64zh),
-
- ("writeCharArrayzh", tWriteMutableByteArrayzh tCharzh),
- ("writeWideCharArrayzh", tWriteMutableByteArrayzh tCharzh),
- ("writeIntArrayzh", tWriteMutableByteArrayzh tIntzh),
- ("writeWordArrayzh", tWriteMutableByteArrayzh tWordzh),
- ("writeAddrArrayzh", tWriteMutableByteArrayzh tAddrzh),
- ("writeFloatArrayzh", tWriteMutableByteArrayzh tFloatzh),
- ("writeDoubleArrayzh", tWriteMutableByteArrayzh tDoublezh),
- ("writeStablePtrArrayzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutableByteArrayzh (Tvar "s"))
- (tArrow tIntzh
- (tArrow (tStablePtrzh (Tvar "a"))
- (tArrow (tStatezh (Tvar "s"))
- (tStatezh (Tvar "s")))))))),
- ("writeInt8Arrayzh", tWriteMutableByteArrayzh tIntzh),
- ("writeInt16Arrayzh", tWriteMutableByteArrayzh tIntzh),
- ("writeInt32Arrayzh", tWriteMutableByteArrayzh tIntzh),
- ("writeInt64Arrayzh", tWriteMutableByteArrayzh tInt64zh),
- ("writeWord8Arrayzh", tWriteMutableByteArrayzh tWordzh),
- ("writeWord16Arrayzh", tWriteMutableByteArrayzh tWordzh),
- ("writeWord32Arrayzh", tWriteMutableByteArrayzh tWord32zh),
- ("writeWord64Arrayzh", tWriteMutableByteArrayzh tWord64zh),
-
- ("indexCharOffAddrzh", tArrow tAddrzh (tArrow tIntzh tCharzh)),
- ("indexWideCharOffAddrzh", tArrow tAddrzh (tArrow tIntzh tCharzh)),
- ("indexIntOffAddrzh", tArrow tAddrzh (tArrow tIntzh tIntzh)),
- ("indexWordOffAddrzh", tArrow tAddrzh (tArrow tIntzh tWordzh)),
- ("indexAddrOffAddrzh", tArrow tAddrzh (tArrow tIntzh tAddrzh)),
- ("indexFloatOffAddrzh", tArrow tAddrzh (tArrow tIntzh tFloatzh)),
- ("indexDoubleOffAddrzh", tArrow tAddrzh (tArrow tIntzh tDoublezh)),
- ("indexStablePtrOffAddrzh", Tforall ("a",Klifted) (tArrow tAddrzh (tArrow tIntzh (tStablePtrzh (Tvar "a"))))),
- ("indexInt8OffAddrzh", tArrow tAddrzh (tArrow tIntzh tIntzh)),
- ("indexInt16OffAddrzh", tArrow tAddrzh (tArrow tIntzh tIntzh)),
- ("indexInt32OffAddrzh", tArrow tAddrzh (tArrow tIntzh tInt32zh)),
- ("indexInt64OffAddrzh", tArrow tAddrzh (tArrow tIntzh tInt64zh)),
- ("indexWord8OffAddrzh", tArrow tAddrzh (tArrow tIntzh tWordzh)),
- ("indexWord16OffAddrzh", tArrow tAddrzh (tArrow tIntzh tWordzh)),
- ("indexWord32ffAddrzh", tArrow tAddrzh (tArrow tIntzh tWord32zh)),
- ("indexWord64OffAddrzh", tArrow tAddrzh (tArrow tIntzh tWord64zh)),
-
- ("indexCharOffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tCharzh)),
- ("indexWideCharOffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tCharzh)),
- ("indexIntOffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tIntzh)),
- ("indexWordOffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tWordzh)),
- ("indexAddrOffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tAddrzh)),
- ("indexFloatOffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tFloatzh)),
- ("indexDoubleOffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tDoublezh)),
- ("indexStablePtrOffForeignObjzh", Tforall ("a",Klifted) (tArrow tForeignObjzh (tArrow tIntzh (tStablePtrzh (Tvar "a"))))),
- ("indexInt8OffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tIntzh)),
- ("indexInt16OffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tIntzh)),
- ("indexInt32OffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tInt32zh)),
- ("indexInt64OffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tInt64zh)),
- ("indexWord8OffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tWordzh)),
- ("indexWord16OffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tWordzh)),
- ("indexWord32ffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tWord32zh)),
- ("indexWord64OffForeignObjzh", tArrow tForeignObjzh (tArrow tIntzh tWord64zh)),
-
- ("readCharOffAddrzh", tReadOffAddrzh tCharzh),
- ("readWideCharOffAddrzh", tReadOffAddrzh tCharzh),
- ("readIntOffAddrzh", tReadOffAddrzh tIntzh),
- ("readWordOffAddrzh", tReadOffAddrzh tWordzh),
- ("readAddrOffAddrzh", tReadOffAddrzh tAddrzh),
- ("readFloatOffAddrzh", tReadOffAddrzh tFloatzh),
- ("readDoubleOffAddrzh", tReadOffAddrzh tDoublezh),
- ("readStablePtrOffAddrzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow tAddrzh
- (tArrow tIntzh
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),tStablePtrzh (Tvar "a")])))))),
- ("readInt8OffAddrzh", tReadOffAddrzh tIntzh),
- ("readInt16OffAddrzh", tReadOffAddrzh tIntzh),
- ("readInt32OffAddrzh", tReadOffAddrzh tInt32zh),
- ("readInt64OffAddrzh", tReadOffAddrzh tInt64zh),
- ("readWord8OffAddrzh", tReadOffAddrzh tWordzh),
- ("readWord16OffAddrzh", tReadOffAddrzh tWordzh),
- ("readWord32OffAddrzh", tReadOffAddrzh tWord32zh),
- ("readWord64OffAddrzh", tReadOffAddrzh tWord64zh),
-
- ("writeCharOffAddrzh", tWriteOffAddrzh tCharzh),
- ("writeWideCharOffAddrzh", tWriteOffAddrzh tCharzh),
- ("writeIntOffAddrzh", tWriteOffAddrzh tIntzh),
- ("writeWordOffAddrzh", tWriteOffAddrzh tWordzh),
- ("writeAddrOffAddrzh", tWriteOffAddrzh tAddrzh),
- ("writeFloatOffAddrzh", tWriteOffAddrzh tFloatzh),
- ("writeDoubleOffAddrzh", tWriteOffAddrzh tDoublezh),
- ("writeStablePtrOffAddrzh", Tforall ("a",Klifted) (tWriteOffAddrzh (tStablePtrzh (Tvar "a")))),
- ("writeInt8OffAddrzh", tWriteOffAddrzh tIntzh),
- ("writeInt16OffAddrzh", tWriteOffAddrzh tIntzh),
- ("writeInt32OffAddrzh", tWriteOffAddrzh tInt32zh),
- ("writeInt64OffAddrzh", tWriteOffAddrzh tInt64zh),
- ("writeWord8OffAddrzh", tWriteOffAddrzh tWordzh),
- ("writeWord16OffAddrzh", tWriteOffAddrzh tWordzh),
- ("writeWord32OffAddrzh", tWriteOffAddrzh tWord32zh),
- ("writeWord64OffAddrzh", tWriteOffAddrzh tWord64zh),
-
- ("sameMutableArrayzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutableArrayzh (Tvar "s") (Tvar "a"))
- (tArrow (tMutableArrayzh (Tvar "s") (Tvar "a"))
- tBool)))),
- ("sameMutableByteArrayzh", Tforall ("s",Klifted)
- (tArrow (tMutableByteArrayzh (Tvar "s"))
- (tArrow (tMutableByteArrayzh (Tvar "s"))
- tBool))),
- ("readArrayzh",Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutableArrayzh (Tvar "s") (Tvar "a"))
- (tArrow tIntzh
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"), Tvar "a"])))))),
- ("writeArrayzh",Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutableArrayzh (Tvar "s") (Tvar "a"))
- (tArrow tIntzh
- (tArrow (Tvar "a")
- (tArrow (tStatezh (Tvar "s"))
- (tStatezh (Tvar "s")))))))),
- ("indexArrayzh", Tforall ("a",Klifted)
- (tArrow (tArrayzh (Tvar "a"))
- (tArrow tIntzh
- (tUtuple[Tvar "a"])))),
- ("unsafeFreezzeArrayzh",Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutableArrayzh (Tvar "s") (Tvar "a"))
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"),tArrayzh (Tvar "a")]))))),
- ("unsafeFreezzeByteArrayzh",Tforall ("s",Klifted)
- (tArrow (tMutableByteArrayzh (Tvar "s"))
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"),tByteArrayzh])))),
- ("unsafeThawArrayzh",Tforall ("a",Klifted)
- (Tforall ("s",Klifted)
- (tArrow (tArrayzh (Tvar "a"))
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"),tMutableArrayzh (Tvar "s") (Tvar "a")]))))),
- ("sizzeofByteArrayzh", tArrow tByteArrayzh tIntzh),
- ("sizzeofMutableByteArrayzh", Tforall ("s",Klifted) (tArrow (tMutableByteArrayzh (Tvar "s")) tIntzh))]
- where
- tReadMutableByteArrayzh t =
- Tforall ("s",Klifted)
- (tArrow (tMutableByteArrayzh (Tvar "s"))
- (tArrow tIntzh
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),t]))))
-
- tWriteMutableByteArrayzh t =
- Tforall ("s",Klifted)
- (tArrow (tMutableByteArrayzh (Tvar "s"))
- (tArrow tIntzh
- (tArrow t
- (tArrow (tStatezh (Tvar "s"))
- (tStatezh (Tvar "s"))))))
-
- tReadOffAddrzh t =
- Tforall ("s",Klifted)
- (tArrow tAddrzh
- (tArrow tIntzh
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),t]))))
-
-
- tWriteOffAddrzh t =
- Tforall ("s",Klifted)
- (tArrow tAddrzh
- (tArrow tIntzh
- (tArrow t
- (tArrow (tStatezh (Tvar "s"))
- (tStatezh (Tvar "s"))))))
-
-{- MutVars -}
-
-tcMutVarzh = (primMname,"MutVarzh")
-tMutVarzh s t = Tapp (Tapp (Tcon tcMutVarzh) s) t
-ktMutVarzh = Karrow Klifted (Karrow Klifted Kunlifted)
-
-opsMutVarzh = [
- ("newMutVarzh", Tforall ("a",Klifted)
- (Tforall ("s",Klifted)
- (tArrow (Tvar "a") (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"),
- tMutVarzh (Tvar "s") (Tvar "a")]))))),
- ("readMutVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutVarzh (Tvar "s")(Tvar "a"))
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"), Tvar "a"]))))),
- ("writeMutVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutVarzh (Tvar "s") (Tvar "a"))
- (tArrow (Tvar "a")
- (tArrow (tStatezh (Tvar "s"))
- (tStatezh (Tvar "s"))))))),
- ("sameMutVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMutVarzh (Tvar "s") (Tvar "a"))
- (tArrow (tMutVarzh (Tvar "s") (Tvar "a"))
- tBool))))]
-
{- Real world and state. -}
-tcRealWorld = (primMname,"RealWorld")
+-- tjc: why isn't this one unboxed?
+tcRealWorld :: Qual Tcon
+tcRealWorld = pv "RealWorld"
+tRealWorld :: Ty
tRealWorld = Tcon tcRealWorld
-ktRealWorld = Klifted
-tcStatezh = (primMname, "Statezh")
+tcStatezh :: Qual Tcon
+tcStatezh = pvz "State"
+tStatezh :: Ty -> Ty
tStatezh t = Tapp (Tcon tcStatezh) t
-ktStatezh = Karrow Klifted Kunlifted
-
-tRWS = tStatezh tRealWorld
-
-opsState = [
- ("realWorldzh", tRWS)]
-
-{- Exceptions -}
-
--- no primitive type
-opsExn = [
- ("catchzh",
- let t' = tArrow tRWS (tUtuple [tRWS, Tvar "a"]) in
- Tforall ("a",Klifted)
- (Tforall ("b",Klifted)
- (tArrow t'
- (tArrow (tArrow (Tvar "b") t')
- t')))),
- ("raisezh", Tforall ("a",Klifted)
- (Tforall ("b",Klifted)
- (tArrow (Tvar "a") (Tvar "b")))),
- ("blockAsyncExceptionszh", Tforall ("a",Klifted)
- (tArrow (tArrow tRWS (tUtuple[tRWS,Tvar "a"]))
- (tArrow tRWS (tUtuple[tRWS,Tvar "a"])))),
- ("unblockAsyncExceptionszh", Tforall ("a",Klifted)
- (tArrow (tArrow tRWS (tUtuple[tRWS,Tvar "a"]))
- (tArrow tRWS (tUtuple[tRWS,Tvar "a"]))))]
-
-{- Mvars -}
-
-tcMVarzh = (primMname, "MVarzh")
-tMVarzh s t = Tapp (Tapp (Tcon tcMVarzh) s) t
-ktMVarzh = Karrow Klifted (Karrow Klifted Kunlifted)
-
-opsMVar = [
- ("newMVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"),tMVarzh (Tvar "s") (Tvar "a")])))),
- ("takeMVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMVarzh (Tvar "s") (Tvar "a"))
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"),Tvar "a"]))))),
- ("tryTakeMVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMVarzh (Tvar "s") (Tvar "a"))
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"),tIntzh,Tvar "a"]))))),
- ("putMVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMVarzh (Tvar "s") (Tvar "a"))
- (tArrow (Tvar "a")
- (tArrow (tStatezh (Tvar "s"))
- (tStatezh (Tvar "s"))))))),
- ("tryPutMVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMVarzh (Tvar "s") (Tvar "a"))
- (tArrow (Tvar "a")
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple [tStatezh (Tvar "s"), tIntzh])))))),
- ("sameMVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMVarzh (Tvar "s") (Tvar "a"))
- (tArrow (tMVarzh (Tvar "s") (Tvar "a"))
- tBool)))),
- ("isEmptyMVarzh", Tforall ("s",Klifted)
- (Tforall ("a",Klifted)
- (tArrow (tMVarzh (Tvar "s") (Tvar "a"))
- (tArrow (tStatezh (Tvar "s"))
- (tUtuple[tStatezh (Tvar "s"),tIntzh])))))]
-
-
-{- Weak Objects -}
-
-tcWeakzh = (primMname, "Weakzh")
-tWeakzh t = Tapp (Tcon tcWeakzh) t
-ktWeakzh = Karrow Klifted Kunlifted
-opsWeak = [
- ("mkWeakzh", Tforall ("o",Kopen)
- (Tforall ("b",Klifted)
- (Tforall ("c",Klifted)
- (tArrow (Tvar "o")
- (tArrow (Tvar "b")
- (tArrow (Tvar "c")
- (tArrow tRWS (tUtuple[tRWS, tWeakzh (Tvar "b")])))))))),
- ("deRefWeakzh", Tforall ("a",Klifted)
- (tArrow (tWeakzh (Tvar "a"))
- (tArrow tRWS (tUtuple[tRWS, tIntzh, Tvar "a"])))),
- ("finalizeWeakzh", Tforall ("a",Klifted)
- (tArrow (tWeakzh (Tvar "a"))
- (tArrow tRWS
- (tUtuple[tRWS,tIntzh,
- tArrow tRWS (tUtuple[tRWS, tUnit])]))))]
-
-
-{- Foreign Objects -}
-
-tcForeignObjzh = (primMname, "ForeignObjzh")
-tForeignObjzh = Tcon tcForeignObjzh
-ktForeignObjzh = Kunlifted
-
-opsForeignObjzh = [
- ("mkForeignObjzh", tArrow tAddrzh
- (tArrow tRWS (tUtuple [tRWS,tForeignObjzh]))),
- ("writeForeignObjzh", Tforall ("s",Klifted)
- (tArrow tForeignObjzh
- (tArrow tAddrzh
- (tArrow (tStatezh (Tvar "s")) (tStatezh (Tvar "s")))))),
- ("foreignObjToAddrzh", tArrow tForeignObjzh tAddrzh),
- ("touchzh", Tforall ("o",Kopen)
- (tArrow (Tvar "o")
- (tArrow tRWS tRWS)))]
-
-
-{- Stable Pointers (but not names) -}
-
-tcStablePtrzh = (primMname, "StablePtrzh")
-tStablePtrzh t = Tapp (Tcon tcStablePtrzh) t
-ktStablePtrzh = Karrow Klifted Kunlifted
-
-opsStablePtrzh = [
- ("makeStablePtrzh", Tforall ("a",Klifted)
- (tArrow (Tvar "a")
- (tArrow tRWS (tUtuple[tRWS,tStablePtrzh (Tvar "a")])))),
- ("deRefStablePtrzh", Tforall ("a",Klifted)
- (tArrow (tStablePtrzh (Tvar "a"))
- (tArrow tRWS (tUtuple[tRWS,Tvar "a"])))),
- ("eqStablePtrzh", Tforall ("a",Klifted)
- (tArrow (tStablePtrzh (Tvar "a"))
- (tArrow (tStablePtrzh (Tvar "a")) tIntzh)))]
-
-{- Concurrency operations -}
-
-tcThreadIdzh = (primMname,"ThreadIdzh")
-tThreadIdzh = Tcon tcThreadIdzh
-ktThreadIdzh = Kunlifted
-
-opsConc = [
- ("seqzh", Tforall ("a",Klifted)
- (tArrow (Tvar "a") tIntzh)),
- ("parzh", Tforall ("a",Klifted)
- (tArrow (Tvar "a") tIntzh)),
- ("delayzh", Tforall ("s",Klifted)
- (tArrow tIntzh (tArrow (tStatezh (Tvar "s")) (tStatezh (Tvar "s"))))),
- ("waitReadzh", Tforall ("s",Klifted)
- (tArrow tIntzh (tArrow (tStatezh (Tvar "s")) (tStatezh (Tvar "s"))))),
- ("waitWritezh", Tforall ("s",Klifted)
- (tArrow tIntzh (tArrow (tStatezh (Tvar "s")) (tStatezh (Tvar "s"))))),
- ("forkzh", Tforall ("a",Klifted)
- (tArrow (Tvar "a")
- (tArrow tRWS (tUtuple[tRWS,tThreadIdzh])))),
- ("killThreadzh", Tforall ("a",Klifted)
- (tArrow tThreadIdzh
- (tArrow (Tvar "a")
- (tArrow tRWS tRWS)))),
- ("yieldzh", tArrow tRWS tRWS),
- ("myThreadIdzh", tArrow tRWS (tUtuple[tRWS, tThreadIdzh]))]
-
-{- Miscellaneous operations -}
-
-opsMisc = [
- ("dataToTagzh", Tforall ("a",Klifted)
- (tArrow (Tvar "a") tIntzh)),
- ("tagToEnumzh", Tforall ("a",Klifted)
- (tArrow tIntzh (Tvar "a"))),
- ("unsafeCoercezh", Tforall ("a",Kopen)
- (Tforall ("b",Kopen)
- (tArrow (Tvar "a") (Tvar "b")))) -- maybe unneeded
- ]
-
-{- CCallable and CReturnable.
- We just define the type constructors for the dictionaries
- corresponding to these pseudo-classes. -}
-
-tcZCTCCallable = (primMname,"ZCTCCallable")
-ktZCTCCallable = Karrow Kopen Klifted -- ??
-tcZCTCReturnable = (primMname,"ZCTCReturnable")
-ktZCTCReturnable = Karrow Kopen Klifted -- ??
+{- Properly defined in PrelError, but needed in many modules before that. -}
+errorVals :: [(Var, Ty)]
+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. -}
-tcUnit = ("PrelBase","Unit")
-tUnit = Tcon tcUnit
-ktUnit = Klifted
-tcBool = ("PrelBase","Bool")
-tBool = Tcon tcBool
-ktBool = Klifted
+bv :: a -> Qual a
+bv = qual baseMname
-{- Properly defined in PrelError, but needed in many modules before that. -}
-errorVals = [
- ("error", Tforall ("a",Kopen) (tArrow tString (Tvar "a"))),
- ("irrefutPatError", Tforall ("a",Kopen) (tArrow tString (Tvar "a"))),
- ("patError", Tforall ("a",Kopen) (tArrow tString (Tvar "a")))]
-
-tcChar = ("PrelBase","Char")
+str2A, forallAA :: Ty
+str2A = Tforall ("a",Kopen) (tArrow tAddrzh (Tvar "a"))
+forallAA = Tforall ("a",Kopen) (Tvar "a")
+
+tBool :: Ty
+tBool = Tcon (Just boolMname, "Bool")
+tcChar :: Qual Tcon
+tcChar = bv "Char"
+tChar :: Ty
tChar = Tcon tcChar
-ktChar = Klifted
-tcList = ("PrelBase","ZMZN")
+tcList :: Qual Tcon
+tcList = bv "ZMZN"
+tList :: Ty -> Ty
tList t = Tapp (Tcon tcList) t
-ktList = Karrow Klifted Klifted
+tString :: Ty
tString = tList tChar
-
-{- Utilities for building types -}
-tmonadic t = tArrow t t
-tdyadic t = tArrow t (tArrow t t)
-tcompare t = tArrow t (tArrow t tBool)
-
+tIntzh, tCharzh, tIOUnit :: Ty
+tIntzh = Tcon (primId "Int#")
+tCharzh = Tcon (primId "Char#")
+tIOUnit = Tapp (Tcon (Just (mkBaseMname "IOBase"), "IO"))
+ (Tcon (bv "Z0T"))
+
+primId :: String -> Qual Id
+primId = pv . zEncodeString
\ No newline at end of file
projects / ghc-hetmet.git / blobdiff