2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[PrelFuns]{Help functions for prelude-related stuff}
7 #include "HsVersions.h"
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,
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,
21 pcDataTyCon, pcPrimTyCon,
22 pcDataCon, pcMiscPrelId,
23 pcGenerateSpecs, pcGenerateDataSpecs, pcGenerateTupleSpecs,
25 -- mkBuild, mkListFilter,
27 -- re-export a few helpful things
28 mkPreludeCoreName, nullSpecEnv,
30 IdInfo, ArityInfo, DemandInfo, SpecEnv, StrictnessInfo,
31 UpdateInfo, ArgUsageInfo, ArgUsage, DeforestInfo, FBTypeInfo,
32 FBType, FBConsum, FBProd,
33 OptIdInfo(..), -- class
35 mkArityInfo, arityMaybe,
36 noInfo_UF, mkUnfolding, UnfoldingGuidance(..), UnfoldingDetails,
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(..),
49 #endif {- Data Parallel Haskell -}
51 PrimOp(..), -- NB: non-abstract
52 PrimKind(..), -- NB: non-abstract
53 Name(..), -- NB: non-abstract
54 UniType(..), -- Mega-NB: non-abstract
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__
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)
79 import Id ( mkPreludeId, mkSpecId, mkDataCon, getIdUniType,
80 mkTemplateLocals, DataCon(..)
83 import Maybes ( Maybe(..) )
84 import Name ( Name(..) )
85 import NameTypes ( mkShortName, mkPreludeCoreName, ShortName, FullName )
89 import PrimKind ( PrimKind(..) )
90 import PrimOps ( PrimOp(..)
91 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
92 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
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)
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")
120 -- things for TyCons -----------------------------------------------------
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
126 arity = length tyvars
127 full_name = mkPreludeCoreName mod name
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
133 full_name = mkPreludeCoreName pRELUDE_BUILTIN name
137 -- things for Ids -----------------------------------------------------
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
143 pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> UniType -> IdInfo -> Id
145 pcMiscPrelId key mod name ty info
146 = mkPreludeId key (mkPreludeCoreName mod name) ty info
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
157 v :: (\/ b . (a -> b -> b) -> b -> b) -> [a]
158 -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a]
160 @e@ is the object right inside the @build@
163 --LATER: mkBuild :: UniType
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)]
176 --LATER: mkListFilter tys args ty ity c n exp
177 --LATER: = foldr CoTyLam
178 --LATER: (CoLam args (mkBuild ty ity c n exp))
183 %************************************************************************
185 \subsection[PrelFuns-specialisations]{Specialisations for builtin values}
187 %************************************************************************
189 The specialisations which exist for the builtin values must be recorded in
192 NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND
193 TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!!
195 HACK: We currently use the same unique for the specialised Ids.
197 The list @specing_types@ determines the types for which specialised
198 versions are created. Note: This should correspond with the
199 types passed to the pre-processor with the -genSPECS arg (see ghc.lprl).
201 ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl
204 pcGenerateSpecs :: Unique -> Id -> IdInfo -> UniType -> SpecEnv
205 pcGenerateSpecs key id info ty
206 = pc_gen_specs True key id info ty
208 pcGenerateDataSpecs :: UniType -> SpecEnv
209 pcGenerateDataSpecs ty
210 = pc_gen_specs False err err err ty
212 err = panic "PrelFuns:GenerateDataSpecs"
214 pcGenerateTupleSpecs :: Int -> UniType -> SpecEnv
215 pcGenerateTupleSpecs arity ty
217 pcGenerateDataSpecs ty
218 else if arity == 5 then
220 tup5_spec jty = SpecInfo (take 5 (repeat jty))
221 0 (panic "SpecData:SpecInfo:SpecId")
223 mkSpecEnv (map tup5_spec (tail specing_types))
224 else if arity == 19 then
225 mkSpecEnv [SpecInfo (Nothing : Just doublePrimTy : take 17 (repeat Nothing))
226 0 (panic "SpecData:SpecInfo:SpecId")]
230 pc_gen_specs is_id key id info ty
231 = mkSpecEnv spec_infos
233 spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0
235 then mkSpecId key {- HACK WARNING: same unique! -}
236 id spec_tys spec_ty info
237 else panic "SpecData:SpecInfo:SpecId"
239 SpecInfo spec_tys (length ctxts) spec_id
240 | spec_tys <- specialisations ]
242 (tyvars, ctxts, _) = splitType ty
243 no_tyvars = length tyvars
245 specialisations = if no_tyvars == 0
247 else tail (cross_product no_tyvars specing_types)
249 -- N.B. tail removes fully polymorphic specialisation
251 cross_product 0 tys = []
252 cross_product 1 tys = map (:[]) tys
253 cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys]
256 specing_types = [Nothing,