ghc/compiler/prelude/PrelFuns.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[PrelFuns]{Help functions for prelude-related stuff}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module PrelFuns (
  10         pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_RATIO,
  11         pRELUDE_LIST, pRELUDE_TEXT,  --OLD: pRELUDE_ARRAY, pRELUDE_COMPLEX,
  12         pRELUDE_PRIMIO, pRELUDE_IO, pRELUDE_PS,
  13         gLASGOW_ST, {-gLASGOW_IO,-} gLASGOW_MISC,
  14
  15         alpha_tv, alpha, beta_tv, beta,
  16         gamma_tv, gamma, delta_tv, delta, epsilon_tv, epsilon,
  17         alpha_tyvar, alpha_ty, beta_tyvar, beta_ty,
  18         gamma_tyvar, gamma_ty, delta_tyvar, delta_ty,
  19         epsilon_tyvar, epsilon_ty,
  20
  21         pcDataTyCon, pcPrimTyCon,
  22         pcDataCon, pcMiscPrelId,
  23         pcGenerateSpecs, pcGenerateDataSpecs,
  24
  25         -- mkBuild, mkListFilter,
  26
  27         -- re-export a few helpful things
  28         mkPreludeCoreName, nullSpecEnv,
  29
  30         IdInfo, ArityInfo, DemandInfo, SpecEnv, StrictnessInfo,
  31         UpdateInfo, ArgUsageInfo, ArgUsage, DeforestInfo, FBTypeInfo,
  32         FBType, FBConsum, FBProd,
  33         OptIdInfo(..),  -- class
  34         noIdInfo,
  35         mkArityInfo, arityMaybe,
  36         noInfo_UF, mkUnfolding, UnfoldingGuidance(..), UnfoldingDetails,
  37
  38         -- and to make the interface self-sufficient...
  39         Outputable(..), NamedThing(..),
  40         ExportFlag, SrcLoc, Unique,
  41         Pretty(..), PprStyle, PrettyRep,
  42         -- urgh: because their instances go out w/ Outputable(..)
  43         BasicLit, CoreBinding, CoreCaseAlternatives, CoreArg,
  44         CoreCaseDefault, CoreExpr, CoreAtom, TyVarEnv(..),
  45         IdEnv(..), UniqFM,
  46 #ifdef DPH
  47         CoreParQuals,
  48         CoreParCommunicate,
  49 #endif {- Data Parallel Haskell -}
  50
  51         PrimOp(..),                     -- NB: non-abstract
  52         PrimKind(..),                   -- NB: non-abstract
  53         Name(..),                               -- NB: non-abstract
  54         UniType(..),                            -- Mega-NB: non-abstract
  55
  56         Class, ClassOp, Id, FullName, ShortName, TyCon, TyVarTemplate,
  57         TyVar, Arity(..), TauType(..), ThetaType(..), SigmaType(..),
  58         CostCentre, GlobalSwitch, Maybe, BinderInfo, PlainCoreExpr(..),
  59         PlainCoreAtom(..), InstTemplate, Demand, Bag
  60         IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
  61 #ifndef __GLASGOW_HASKELL__
  62         ,TAG_
  63 #endif
  64     ) where
  65
  66 import AbsUniType       ( mkDataTyCon, mkPrimTyCon,
  67                           specialiseTy, splitType, applyTyCon,
  68                           alpha_tv, alpha, beta_tv, beta, gamma_tv,
  69                           gamma, alpha_tyvar, alpha_ty, beta_tyvar,
  70                           beta_ty, gamma_tyvar, gamma_ty, delta_tv,
  71                           delta, epsilon_tv, epsilon, delta_tyvar,
  72                           delta_ty, epsilon_tyvar, epsilon_ty, TyVar,
  73                           TyVarTemplate, Class, ClassOp, TyCon,
  74                           Arity(..), ThetaType(..), TauType(..),
  75                           SigmaType(..), UniType, InstTemplate
  76                           IF_ATTACK_PRAGMAS(COMMA pprUniType)
  77                           IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar)
  78                         )
  79 import Id               ( mkPreludeId, mkSpecId, mkDataCon, getIdUniType,
  80                           mkTemplateLocals, DataCon(..)
  81                         )
  82 import IdInfo           -- lots
  83 import Maybes           ( Maybe(..) )
  84 import Name             ( Name(..) )
  85 import NameTypes        ( mkShortName, mkPreludeCoreName, ShortName, FullName )
  86 import Outputable
  87 import PlainCore
  88 import Pretty
  89 import PrimKind         ( PrimKind(..) )
  90 import PrimOps          ( PrimOp(..)
  91                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  92                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  93                         )
  94 import SrcLoc           ( mkBuiltinSrcLoc, SrcLoc )
  95 import TysPrim          ( charPrimTy, intPrimTy, doublePrimTy )
  96 import UniType          ( UniType(..)   -- **** CAN SEE THE CONSTRUCTORS ****
  97                           IF_ATTACK_PRAGMAS(COMMA cmpUniType)
  98                         )
  99 import Util
 100 \end{code}
 101
 102 \begin{code}
 103 pRELUDE         = SLIT("Prelude")
 104 pRELUDE_BUILTIN = SLIT("PreludeBuiltin")
 105 pRELUDE_CORE    = SLIT("PreludeCore")
 106 pRELUDE_RATIO   = SLIT("PreludeRatio")
 107 pRELUDE_LIST    = SLIT("PreludeList")
 108 --OLD:pRELUDE_ARRAY     = SLIT("PreludeArray")
 109 pRELUDE_TEXT    = SLIT("PreludeText")
 110 --OLD:pRELUDE_COMPLEX   = SLIT("PreludeComplex")
 111 pRELUDE_PRIMIO  = SLIT("PreludePrimIO")
 112 pRELUDE_IO      = SLIT("PreludeIO")
 113 pRELUDE_PS      = SLIT("PreludePS")
 114 gLASGOW_ST      = SLIT("PreludeGlaST")
 115 --gLASGOW_IO    = SLIT("PreludeGlaIO")
 116 gLASGOW_MISC    = SLIT("PreludeGlaMisc")
 117 \end{code}
 118
 119 \begin{code}
 120 -- things for TyCons -----------------------------------------------------
 121
 122 pcDataTyCon :: Unique{-TyConKey-} -> FAST_STRING -> FAST_STRING -> [TyVarTemplate] -> [Id] -> TyCon
 123 pcDataTyCon key mod name tyvars cons
 124   = mkDataTyCon key full_name arity tyvars cons [{-no derivings-}] True
 125   where
 126     arity     = length tyvars
 127     full_name = mkPreludeCoreName mod name
 128
 129 pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> ([PrimKind] -> PrimKind) -> TyCon
 130 pcPrimTyCon key name arity kind_fn
 131   = mkPrimTyCon key full_name arity kind_fn
 132   where
 133     full_name = mkPreludeCoreName pRELUDE_BUILTIN name
 134 \end{code}
 135
 136 \begin{code}
 137 -- things for Ids -----------------------------------------------------
 138
 139 pcDataCon :: Unique{-DataConKey-} -> FAST_STRING -> FAST_STRING -> [TyVarTemplate] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id
 140 pcDataCon key mod name tyvars context arg_tys tycon specenv
 141   = mkDataCon key (mkPreludeCoreName mod name) tyvars context arg_tys tycon specenv
 142
 143 pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> UniType -> IdInfo -> Id
 144
 145 pcMiscPrelId key mod name ty info
 146  = mkPreludeId  key (mkPreludeCoreName mod name) ty info
 147 \end{code}
 148
 149 @mkBuild@ is suger for building a build !
 150 @mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@
 151 @ty@ is the type of the list.
 152 @tv@ is always a new type variable.
 153 @c,n@ are Id's for the abstract cons and nil
 154 \begin{verbatim}
 155         c :: a -> b -> b
 156         n :: b
 157         v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
 158 --  \/ a .  (\/ b . (a -> b -> b) -> b -> b) -> [a]
 159 \end{verbatim}
 160 @e@ is the object right inside the @build@
 161
 162 \begin{code}
 163 --LATER: mkBuild :: UniType
 164 --LATER:        -> TyVar
 165 --LATER:        -> Id
 166 --LATER:        -> Id
 167 --LATER:        -> PlainCoreExpr
 168 --LATER:        -> PlainCoreExpr
 169 --LATER: mkBuild ty tv c n expr
 170 --LATER:  = CoApp (CoTyApp (CoVar buildId) ty)
 171 --LATER:               (CoTyLam tv (mkCoLam [c,n] expr))
 172 --LATER: -- CoCon buildDataCon [ty] [CoTyLam tv (mkCoLam [c,n] expr)]
 173 \end{code}
 174
 175 \begin{code}
 176 --LATER: mkListFilter tys args ty ity c n exp
 177 --LATER:   = foldr CoTyLam
 178 --LATER:         (CoLam args (mkBuild ty ity c n exp))
 179 --LATER:          tys
 180 \end{code}
 181
 182
 183 %************************************************************************
 184 %*                                                                      *
 185 \subsection[PrelFuns-specialisations]{Specialisations for builtin values}
 186 %*                                                                      *
 187 %************************************************************************
 188
 189 The specialisations which exist for the builtin values must be recorded in
 190 their IdInfos.
 191
 192 HACK: We currently use the same unique for the specialised Ids.
 193
 194 The list @specing_types@ determines the types for which specialised
 195 versions are created. Note: This should correspond with the
 196 @SpecingTypes@ in hscpp.prl.
 197
 198 ToDo: Automatic generation of required specialised versions.
 199
 200 \begin{code}
 201 pcGenerateSpecs :: Unique -> Id -> IdInfo -> UniType -> SpecEnv
 202 pcGenerateSpecs key id info ty
 203   = pc_gen_specs True key id info ty
 204
 205 pcGenerateDataSpecs :: UniType -> SpecEnv
 206 pcGenerateDataSpecs ty
 207   = pc_gen_specs False err err err ty
 208   where
 209     err = panic "PrelFuns:GenerateDataSpecs"
 210
 211
 212 pc_gen_specs is_id key id info ty
 213  = mkSpecEnv spec_infos
 214  where
 215    spec_infos = [ let spec_ty = specialiseTy ty ty_maybes 0
 216                       spec_id = if is_id
 217                                 then mkSpecId key {- HACK WARNING: same unique! -}
 218                                               id ty_maybes spec_ty info
 219                                 else panic "SpecData:SpecInfo:SpecId"
 220                   in
 221                   SpecInfo ty_maybes (length ctxts) spec_id
 222                 | ty_maybes <- tail (cross_product (length tyvars) specing_types) ]
 223
 224                         -- N.B. tail removes fully polymorphic specialisation
 225
 226    (tyvars, ctxts, _) = splitType ty
 227
 228    cross_product 0 tys = panic "PrelFuns:cross_product"
 229    cross_product 1 tys = map (:[]) tys
 230    cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
 231
 232
 233 -- Note: The Just types should correspond to SpecingTypes in hscpp.prl
 234
 235 specing_types = [Nothing,
 236                  Just charPrimTy,
 237                  Just doublePrimTy,
 238                  Just intPrimTy ]
 239 \end{code}