X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrelVals.lhs;h=37d6f6b746c8d0b4b46825016b884fc28e8b9cf6;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=ba6118b213fbcfff9d88b00d78def6d41637a637;hpb=68a1f0233996ed79824d11d946e9801473f6946c;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index ba6118b..37d6f6b 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[PrelVals]{Prelude values the compiler ``knows about''} @@ -8,34 +8,45 @@ module PrelVals where -import PrelFuns -- help functions, types and things -import BasicLit ( mkMachInt, BasicLit(..), PrimKind ) +IMP_Ubiq() +IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..), nullSpecEnv, SpecEnv ) +import Id ( SYN_IE(Id), GenId, mkImported, mkUserId, mkTemplateLocals ) +IMPORT_DELOOPER(PrelLoop) + +-- friends: +import PrelMods import TysPrim import TysWiredIn -#ifdef DPH -import TyPod ( mkPodNTy ,mkPodTy ) -import TyProcs ( mkProcessorTy ) -#endif {- Data Parallel Haskell -} - -#ifndef DPH -import AbsUniType -import Id ( mkTemplateLocals, mkTupleCon, getIdUniType, - mkSpecId - ) -#else -import AbsUniType ( mkSigmaTy, mkDictTy, mkTyVarTy , SigmaType(..), - applyTyCon, splitType, specialiseTy - ) -import Id ( mkTemplateLocals, mkTupleCon, getIdUniType, - mkSpecId, mkProcessorCon - ) -#endif {- Data Parallel Haskell -} -import IdInfo - -import Maybes ( Maybe(..) ) -import PlainCore -- to make unfolding templates -import Unique -- *Key things -import Util + +-- others: +import CmdLineOpts ( maybe_CompilingGhcInternals ) +import CoreSyn -- quite a bit +import IdInfo -- quite a bit +import Literal ( mkMachInt ) +import Name ( ExportFlag(..) ) +import PragmaInfo +import PrimOp ( PrimOp(..) ) +import Type ( mkTyVarTy ) +import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar ) +import Unique -- lots of *Keys +import Util ( panic ) +\end{code} + +\begin{code} +-- only used herein: +pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id + +pcMiscPrelId key m n ty info + = let + name = mkWiredInName key (OrigName m n) ExportAll + imp = mkImported name ty info -- the usual case... + in + imp + -- We lie and say the thing is imported; otherwise, we get into + -- a mess with dependency analysis; e.g., core2stg may heave in + -- random calls to GHCbase.unpackPS__. If GHCbase is the module + -- being compiled, then it's just a matter of luck if the definition + -- will be in "the right place" to be in scope. \end{code} %************************************************************************ @@ -46,15 +57,15 @@ import Util GHC randomly injects these into the code. -@patError#@ is just a version of @error@ for pattern-matching +@patError@ is just a version of @error@ for pattern-matching failures. It knows various ``codes'' which expand to longer strings---this saves space! -@absent#@ is a thing we put in for ``absent'' arguments. They jolly +@absentErr@ is a thing we put in for ``absent'' arguments. They jolly well shouldn't be yanked on, but if one is, then you will get a -friendly message from @absent#@ (rather a totally random crash). +friendly message from @absentErr@ (rather a totally random crash). -@parError#@ is a special version of @error@ which the compiler does +@parError@ is a special version of @error@ which the compiler does not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ templates, but we don't ever expect to generate code for it. @@ -66,36 +77,50 @@ pc_bottoming_Id key mod name ty -- these "bottom" out, no matter what their arguments eRROR_ID - = pc_bottoming_Id errorIdKey pRELUDE_BUILTIN SLIT("error") errorTy + = pc_bottoming_Id errorIdKey pRELUDE SLIT("error") errorTy + +generic_ERROR_ID u n + = pc_bottoming_Id u SLIT("GHCerr") n errorTy pAT_ERROR_ID - = pc_bottoming_Id patErrorIdKey pRELUDE_BUILTIN SLIT("patError#") errorTy + = generic_ERROR_ID patErrorIdKey SLIT("patError") +rEC_CON_ERROR_ID + = generic_ERROR_ID recConErrorIdKey SLIT("recConError") +rEC_UPD_ERROR_ID + = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError") +iRREFUT_PAT_ERROR_ID + = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError") +nON_EXHAUSTIVE_GUARDS_ERROR_ID + = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError") +nO_DEFAULT_METHOD_ERROR_ID + = generic_ERROR_ID noDefaultMethodErrorIdKey SLIT("noDefaultMethodError") +nO_EXPLICIT_METHOD_ERROR_ID + = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError") aBSENT_ERROR_ID - = pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#") - (mkSigmaTy [alpha_tv] [] alpha) + = pc_bottoming_Id absentErrorIdKey SLIT("GHCerr") SLIT("absentErr") + (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) pAR_ERROR_ID - = pcMiscPrelId parErrorIdKey pRELUDE_BUILTIN SLIT("parError#") - (mkSigmaTy [alpha_tv] [] alpha) noIdInfo + = pcMiscPrelId parErrorIdKey SLIT("GHCerr") SLIT("parError") + (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo + +openAlphaTy = mkTyVarTy openAlphaTyVar -errorTy :: UniType -errorTy = mkSigmaTy [alpha_tv] [] (UniFun (mkListTy charTy) alpha) +errorTy :: Type +errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy) \end{code} -We want \tr{_trace} (NB: name not in user namespace) to be wired in +We want \tr{GHCbase.trace} to be wired in because we don't want the strictness analyser to get ahold of it, decide that the second argument is strict, evaluate that first (!!), -and make a jolly old mess. Having \tr{_trace} wired in also helps when -attempting to re-export it---because it's in \tr{PreludeBuiltin}, it -won't get an \tr{import} declaration in the interface file, so the -importing-subsequently module needs to know it's magic. +and make a jolly old mess. \begin{code} tRACE_ID - = pcMiscPrelId traceIdKey pRELUDE_BUILTIN SLIT("_trace") traceTy + = pcMiscPrelId traceIdKey gHC__ SLIT("trace") traceTy (noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy) where - traceTy = mkSigmaTy [alpha_tv] [] (UniFun (mkListTy charTy) (UniFun alpha alpha)) + traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy) \end{code} %************************************************************************ @@ -105,50 +130,55 @@ tRACE_ID %************************************************************************ \begin{code} -{- OLD: -int2IntegerId - = pcMiscPrelId int2IntegerIdKey pRELUDE_BUILTIN SLIT("_int2Integer") - (UniFun intTy integerTy) - noIdInfo --} +packStringForCId + = pcMiscPrelId packCStringIdKey{-ToDo:rename-} gHC__ SLIT("packStringForC__") + (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo -------------------------------------------------------------------- unpackCStringId - = pcMiscPrelId unpackCStringIdKey pRELUDE_PS SLIT("unpackPS#") - (addrPrimTy{-a char *-} `UniFun` stringTy) noIdInfo + = pcMiscPrelId unpackCStringIdKey gHC__ SLIT("unpackPS__") + (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo +-- Andy says: +-- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1) +-- but I don't like wired-in IdInfos (WDP) unpackCString2Id -- for cases when a string has a NUL in it - = pcMiscPrelId unpackCString2IdKey pRELUDE_PS SLIT("unpackPS2#") - (addrPrimTy{-a char *-} - `UniFun` (intPrimTy -- length - `UniFun` stringTy)) noIdInfo + = pcMiscPrelId unpackCString2IdKey gHC__ SLIT("unpackPS2__") + (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy) + noIdInfo -------------------------------------------------------------------- unpackCStringAppendId - = pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackCStringAppend#") - (addrPrimTy{-a "char *" pointer-} - `UniFun` (stringTy - `UniFun` stringTy)) noIdInfo - --------------------------------------------------------------------- - -packStringForCId - = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC") - (UniFun stringTy byteArrayPrimTy) noIdInfo + = pcMiscPrelId unpackCStringAppendIdKey gHC__ SLIT("unpackAppendPS__") + (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy) + ((noIdInfo + {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-}) + `addInfo` mkArityInfo 2) + +unpackCStringFoldrId + = pcMiscPrelId unpackCStringFoldrIdKey gHC__ SLIT("unpackFoldrPS__") + (mkSigmaTy [alphaTyVar] [] + (mkFunTys [addrPrimTy{-a "char *" pointer-}, + mkFunTys [charTy, alphaTy] alphaTy, + alphaTy] + alphaTy)) + ((noIdInfo + {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey-}) + `addInfo` mkArityInfo 3) \end{code} OK, this is Will's idea: we should have magic values for Integers 0, +1, +2, and -1 (go ahead, fire me): \begin{code} integerZeroId - = pcMiscPrelId integerZeroIdKey pRELUDE_CORE SLIT("__integer0") integerTy noIdInfo + = pcMiscPrelId integerZeroIdKey gHC__ SLIT("integer_0") integerTy noIdInfo integerPlusOneId - = pcMiscPrelId integerPlusOneIdKey pRELUDE_CORE SLIT("__integer1") integerTy noIdInfo + = pcMiscPrelId integerPlusOneIdKey gHC__ SLIT("integer_1") integerTy noIdInfo integerPlusTwoId - = pcMiscPrelId integerPlusTwoIdKey pRELUDE_CORE SLIT("__integer2") integerTy noIdInfo + = pcMiscPrelId integerPlusTwoIdKey gHC__ SLIT("integer_2") integerTy noIdInfo integerMinusOneId - = pcMiscPrelId integerMinusOneIdKey pRELUDE_CORE SLIT("__integerm1") integerTy noIdInfo + = pcMiscPrelId integerMinusOneIdKey gHC__ SLIT("integer_m1") integerTy noIdInfo \end{code} %************************************************************************ @@ -157,52 +187,44 @@ integerMinusOneId %* * %************************************************************************ -In the definitions that follow, we use the @TyVar@-based -alpha/beta/gamma types---not the usual @TyVarTemplate@ ones. - -This is so the @TyVars@ in the @CoTyLams@ (@alpha_tyvar@, etc) match -up with those in the types of the {\em lambda-bound} template-locals -we create (using types @alpha_ty@, etc.). - \begin{code} +{- OUT: -------------------------------------------------------------------- --- seqId :: "_seq_", used w/ GRIP, etc., is really quite similar to +-- seqId :: "seq", used w/ GRIP, etc., is really quite similar to -- dangerousEval {- OLDER: - _seq_ = /\ a b -> \ x y -> case x of { _ -> y } + seq = /\ a b -> \ x y -> case x of { _ -> y } OLD: - _seq_ = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' } + seq = /\ a b -> \ x y -> case seq# x y of { _Lift y' -> y' } NEW (95/05): - _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; } + seq = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y; } -} -seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_") - (mkSigmaTy [alpha_tv, beta_tv] [] - (alpha `UniFun` (beta `UniFun` beta))) +seqId = pcMiscPrelId seqIdKey gHC__ SLIT("seq") + (mkSigmaTy [alphaTyVar, betaTyVar] [] + (mkFunTys [alphaTy, betaTy] betaTy)) (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template)) where [x, y, z] = mkTemplateLocals [ - {-x-} alpha_ty, - {-y-} beta_ty, - {-z-} intPrimTy + {-x-} alphaTy, + {-y-} betaTy, + {-z-} intPrimTy ] seq_template - = CoTyLam alpha_tyvar - (CoTyLam beta_tyvar - (mkCoLam [x, y] ( - CoCase (CoPrim SeqOp [alpha_ty] [CoVarAtom x]) ( - CoPrimAlts - [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)] - (CoBindDefault z (CoVar y)))))) + = mkLam [alphaTyVar, betaTyVar] [x, y] ( + Case (Prim SeqOp [TyArg alphaTy, VarArg x]) ( + PrimAlts + [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] + (BindDefault z (Var y)))) -------------------------------------------------------------------- --- parId :: "_par_", also used w/ GRIP, etc. +-- parId :: "par", also used w/ GRIP, etc. {- OLDER: @@ -210,330 +232,312 @@ seqId = pcMiscPrelId seqIdKey pRELUDE_BUILTIN SLIT("_seq_") OLD: - _par_ = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' } + par = /\ a b -> \ x y -> case par# x y of { _Lift y' -> y' } NEW (95/05): - _par_ = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; } + par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; } -} -parId = pcMiscPrelId parIdKey pRELUDE_BUILTIN SLIT("_par_") - (mkSigmaTy [alpha_tv, beta_tv] [] - (alpha `UniFun` (beta `UniFun` beta))) +parId = pcMiscPrelId parIdKey gHC__ SLIT("par") + (mkSigmaTy [alphaTyVar, betaTyVar] [] + (mkFunTys [alphaTy, betaTy] betaTy)) (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template)) where [x, y, z] = mkTemplateLocals [ - {-x-} alpha_ty, - {-y-} beta_ty, - {-z-} intPrimTy + {-x-} alphaTy, + {-y-} betaTy, + {-z-} intPrimTy ] par_template - = CoTyLam alpha_tyvar - (CoTyLam beta_tyvar - (mkCoLam [x, y] ( - CoCase (CoPrim ParOp [alpha_ty] [CoVarAtom x]) ( - CoPrimAlts - [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)] - (CoBindDefault z (CoVar y)))))) - --- forkId :: "_fork_", for *required* concurrent threads + = mkLam [alphaTyVar, betaTyVar] [x, y] ( + Case (Prim ParOp [TyArg alphaTy, VarArg x]) ( + PrimAlts + [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] + (BindDefault z (Var y)))) + +-- forkId :: "fork", for *required* concurrent threads {- _fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; } -} -forkId = pcMiscPrelId forkIdKey pRELUDE_BUILTIN SLIT("_fork_") - (mkSigmaTy [alpha_tv, beta_tv] [] - (alpha `UniFun` (beta `UniFun` beta))) +forkId = pcMiscPrelId forkIdKey gHC__ SLIT("fork") + (mkSigmaTy [alphaTyVar, betaTyVar] [] + (mkFunTys [alphaTy, betaTy] betaTy)) (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template)) where [x, y, z] = mkTemplateLocals [ - {-x-} alpha_ty, - {-y-} beta_ty, - {-z-} intPrimTy + {-x-} alphaTy, + {-y-} betaTy, + {-z-} intPrimTy ] fork_template - = CoTyLam alpha_tyvar - (CoTyLam beta_tyvar - (mkCoLam [x, y] ( - CoCase (CoPrim ForkOp [alpha_ty] [CoVarAtom x]) ( - CoPrimAlts - [(mkMachInt 0, CoTyApp (CoVar pAR_ERROR_ID) beta_ty)] - (CoBindDefault z (CoVar y)))))) - + = mkLam [alphaTyVar, betaTyVar] [x, y] ( + Case (Prim ForkOp [TyArg alphaTy, VarArg x]) ( + PrimAlts + [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] + (BindDefault z (Var y)))) +-} \end{code} +GranSim ones: \begin{code} -#ifdef GRAN - -parLocalId = pcMiscPrelId parLocalIdKey pRELUDE_BUILTIN SLIT("_parLocal_") - (mkSigmaTy [alpha_tv, beta_tv] [] - (intPrimTy `UniFun` (alpha `UniFun` (beta `UniFun` beta)))) +{- OUT: +parLocalId = pcMiscPrelId parLocalIdKey gHC__ SLIT("parLocal") + (mkSigmaTy [alphaTyVar, betaTyVar] [] + (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template)) where - [w, x, y, z] + -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL + [w, g, s, p, x, y, z] = mkTemplateLocals [ {-w-} intPrimTy, - {-x-} alpha_ty, - {-y-} beta_ty, - {-z-} beta_ty + {-g-} intPrimTy, + {-s-} intPrimTy, + {-p-} intPrimTy, + {-x-} alphaTy, + {-y-} betaTy, + {-z-} intPrimTy ] parLocal_template - = CoTyLam alpha_tyvar - (CoTyLam beta_tyvar - (mkCoLam [w, x, y] ( - CoCase (CoPrim ParLocalOp [alpha_ty, beta_ty] [CoVarAtom x, CoVarAtom w, CoVarAtom y]) ( - CoAlgAlts - [(liftDataCon, [z], CoVar z)] - (CoNoDefault))))) - -parGlobalId = pcMiscPrelId parGlobalIdKey pRELUDE_BUILTIN SLIT("_parGlobal_") - (mkSigmaTy [alpha_tv, beta_tv] [] - (intPrimTy `UniFun` (alpha `UniFun` (beta `UniFun` beta)))) + = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] ( + Case (Prim ParLocalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) ( + PrimAlts + [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] + (BindDefault z (Var y)))) + +parGlobalId = pcMiscPrelId parGlobalIdKey gHC__ SLIT("parGlobal") + (mkSigmaTy [alphaTyVar, betaTyVar] [] + (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template)) where - [w, x, y, z] + -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL + [w, g, s, p, x, y, z] = mkTemplateLocals [ {-w-} intPrimTy, - {-x-} alpha_ty, - {-y-} beta_ty, - {-z-} beta_ty + {-g-} intPrimTy, + {-s-} intPrimTy, + {-p-} intPrimTy, + {-x-} alphaTy, + {-y-} betaTy, + {-z-} intPrimTy ] parGlobal_template - = CoTyLam alpha_tyvar - (CoTyLam beta_tyvar - (mkCoLam [w, x, y] ( - CoCase (CoPrim ParGlobalOp [alpha_ty, beta_ty] [CoVarAtom x, CoVarAtom w, CoVarAtom y]) ( - CoAlgAlts - [(liftDataCon, [z], CoVar z)] - (CoNoDefault))))) - -#endif {-GRAN-} -\end{code} - -\begin{code} -#ifdef DPH -vectorMapId = pcChooseToKnowId vectorMapU pRELUDE "vectorMap" - (mkSigmaTy [alpha_tv, beta_tv , gamma_tv] - [(pidClass,alpha)] - ((beta `UniFun` gamma) `UniFun` - ((mkPodTy (mkProcessorTy [alpha] beta)) `UniFun` - (mkPodTy (mkProcessorTy [alpha] gamma))))) - (panic "vectorMap:unfolding")--ToDo:DPH: (mkUnfoldTemplate vector_map_template) - [(2,"","")] - where -{- -vectorMap fn vec = << (|x;fn y|) | (|x;y|) <<- vec >> - -Simplified : -vectorMap :: for all a.83, b.82, c.86. - -> (b.82 -> c.86) - -> <> - -> <> -vectorMap = - /\ t83 t82 o86 -> \ dict.127 -> - let - vecMap.128 = - \ fn.129 vec.130 -> - << let si.133 = fn.129 ds.132 in - let - si.134 = - (fromDomain t82) - dict.127 ((toDomain t82) dict.127 ds.131) - in MkProcessor1! Integer o86 si.134 si.133 | - (| ds.131 ; ds.132 |) <<- vec.130 >> - in vecMap.128 - - NOTE : no need to bother with overloading in class Pid; because the result - PID (si.133) is wrapped in fromDomain.toDomain == id . Therefore we - use the simplification below. - -Simplified: -vectorMap :: - for all d.83, e.82, f.86. - -> (d.83 -> f.86) -> <> -> <> -vectorMap = - /\ t83 t82 o86 -> \ dict.127 fn.129 vec.130 -> - << MkProcessor1! Integer o86 ds.131 (fn.129 ds.132) | - (| ds.131 ; ds.132 |) <<- vec.130 >> --} + = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, x, y] ( + Case (Prim ParGlobalOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) ( + PrimAlts + [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] + (BindDefault z (Var y)))) + + +parAtId = pcMiscPrelId parAtIdKey gHC__ SLIT("parAt") + (mkSigmaTy [alphaTyVar, betaTyVar] [] + (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, + alphaTy, betaTy, gammaTy] gammaTy)) + (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAt_template)) + where + -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL + [w, g, s, p, v, x, y, z] + = mkTemplateLocals [ + {-w-} intPrimTy, + {-g-} intPrimTy, + {-s-} intPrimTy, + {-p-} intPrimTy, + {-v-} alphaTy, + {-x-} betaTy, + {-y-} gammaTy, + {-z-} intPrimTy + ] - vector_map_template - = let - [dict,fn,vec,ds131,ds132] - = mkTemplateLocals - [mkDictTy pidClass alpha_ty, - beta_ty `UniFun` gamma_ty, - mkPodTy (mkProcessorTy [alpha_ty] beta_ty), - integerTy, - beta_ty] - in - CoTyLam alpha_tyvar - (CoTyLam beta_tyvar - (CoTyLam gamma_tyvar - (mkCoLam [dict,fn,vec] - (CoZfExpr - (CoCon (mkProcessorCon 1) - [integerTy,mkTyVarTy gamma_tyvar] - [CoVar ds131, - (CoApp (CoVar fn) (CoVar ds132))]) - (CoDrawnGen [ds131] ds132 (CoVar vec)) )))) - -#endif {- Data Parallel Haskell -} -\end{code} + parAt_template + = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] ( + Case (Prim ParAtOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) ( + PrimAlts + [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])] + (BindDefault z (Var y)))) + +parAtAbsId = pcMiscPrelId parAtAbsIdKey gHC__ SLIT("parAtAbs") + (mkSigmaTy [alphaTyVar, betaTyVar] [] + (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) + (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtAbs_template)) + where + -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL + [w, g, s, p, v, x, y, z] + = mkTemplateLocals [ + {-w-} intPrimTy, + {-g-} intPrimTy, + {-s-} intPrimTy, + {-p-} intPrimTy, + {-v-} intPrimTy, + {-x-} alphaTy, + {-y-} betaTy, + {-z-} intPrimTy + ] -\begin{code} -#ifdef DPH --- A function used during podization that produces an index POD for a given --- POD as argument. - -primIfromPodNSelectorId :: Int -> Int -> Id -primIfromPodNSelectorId i n - = pcMiscPrelId - podSelectorIdKey - pRELUDE_BUILTIN - ("prim"++ show i ++ "fromPod" ++ show n ++ "Selector") - (UniFun - (mkPodNTy n alpha) - (mkPodNTy n alpha)) - noIdInfo -#endif {- Data Parallel Haskell -} -\end{code} + parAtAbs_template + = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] ( + Case (Prim ParAtAbsOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) ( + PrimAlts + [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] + (BindDefault z (Var y)))) + +parAtRelId = pcMiscPrelId parAtRelIdKey gHC__ SLIT("parAtRel") + (mkSigmaTy [alphaTyVar, betaTyVar] [] + (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) + (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtRel_template)) + where + -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL + [w, g, s, p, v, x, y, z] + = mkTemplateLocals [ + {-w-} intPrimTy, + {-g-} intPrimTy, + {-s-} intPrimTy, + {-p-} intPrimTy, + {-v-} intPrimTy, + {-x-} alphaTy, + {-y-} betaTy, + {-z-} intPrimTy + ] -%************************************************************************ -%* * -\subsection[PrelVals-deriving]{Values known about mainly for doing derived instance decls} -%* * -%************************************************************************ + parAtRel_template + = mkLam [alphaTyVar, betaTyVar] [w, g, s, p, v, x, y] ( + Case (Prim ParAtRelOp [TyArg alphaTy, TyArg betaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) ( + PrimAlts + [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] + (BindDefault z (Var y)))) + +parAtForNowId = pcMiscPrelId parAtForNowIdKey gHC__ SLIT("parAtForNow") + (mkSigmaTy [alphaTyVar, betaTyVar] [] + (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, + alphaTy, betaTy, gammaTy] gammaTy)) + (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtForNow_template)) + where + -- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL + [w, g, s, p, v, x, y, z] + = mkTemplateLocals [ + {-w-} intPrimTy, + {-g-} intPrimTy, + {-s-} intPrimTy, + {-p-} intPrimTy, + {-v-} alphaTy, + {-x-} betaTy, + {-y-} gammaTy, + {-z-} intPrimTy + ] -map :: (a -> b) -> [a] -> [b] - -- this is up in the here-because-of-unfolding list + parAtForNow_template + = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] ( + Case (Prim ParAtForNowOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) ( + PrimAlts + [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])] + (BindDefault z (Var y)))) ---??showChar :: Char -> ShowS -showSpace :: ShowS -- non-std: == "showChar ' '" -showString :: String -> ShowS -showParen :: Bool -> ShowS -> ShowS +-- copyable and noFollow are currently merely hooks: they are translated into +-- calls to the macros COPYABLE and NOFOLLOW -- HWL -(++) :: [a] -> [a] -> [a] -readParen :: Bool -> ReadS a -> ReadS a -lex :: ReadS String +copyableId = pcMiscPrelId copyableIdKey gHC__ SLIT("copyable") + (mkSigmaTy [alphaTyVar] [] + alphaTy) + (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding copyable_template)) + where + -- Annotations: x: closure that's tagged to by copyable + [x, z] + = mkTemplateLocals [ + {-x-} alphaTy, + {-z-} alphaTy + ] -\begin{code} -{- OLD: -readS_ty :: UniType -> UniType -readS_ty ty - = UniFun stringTy (mkListTy (mkTupleTy 2 [ty, stringTy])) + copyable_template + = mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] ) -showS_ty :: UniType -showS_ty = UniFun stringTy stringTy --} -\end{code} +noFollowId = pcMiscPrelId noFollowIdKey gHC__ SLIT("noFollow") + (mkSigmaTy [alphaTyVar] [] + alphaTy) + (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding noFollow_template)) + where + -- Annotations: x: closure that's tagged to not follow + [x, z] + = mkTemplateLocals [ + {-x-} alphaTy, + {-z-} alphaTy + ] -\begin{code} -{- OLD: -showSpaceId = pcMiscPrelId showSpaceIdKey pRELUDE_TEXT SLIT("_showSpace") - showS_ty - noIdInfo - -showParenId = pcMiscPrelId showParenIdKey pRELUDE_TEXT SLIT("showParen") - (boolTy `UniFun` (showS_ty `UniFun` showS_ty)) - noIdInfo - -readParenId = pcMiscPrelId readParenIdKey pRELUDE_TEXT SLIT("readParen") - (mkSigmaTy [alpha_tv] [] ( - boolTy `UniFun` ( - (readS_ty alpha) `UniFun` (readS_ty alpha)))) - noIdInfo - -lexId = pcMiscPrelId lexIdKey pRELUDE_TEXT SLIT("lex") - (readS_ty (mkListTy charTy)) - noIdInfo + noFollow_template + = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] ) -} \end{code} %************************************************************************ %* * -\subsection[PrelVals-void]{@void#@: Magic value of type @Void#@} +\subsection[PrelVals-runST]{@runST@: Magic start-state-transformer function} %* * %************************************************************************ -I don't think this is available to the user; it's used in the -simplifier (WDP 94/06). -\begin{code} -voidPrimId - = pcMiscPrelId voidPrimIdKey pRELUDE_BUILTIN SLIT("void#") - voidPrimTy noIdInfo -\end{code} - -%************************************************************************ -%* * -\subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function} -%* * -%************************************************************************ - -@_runST@ has a non-Haskell-able type: +@runST@ has a non-Haskell-able type: \begin{verbatim} --- _runST :: forall a. (forall s. _ST s a) -> a +-- runST :: forall a. (forall s. _ST s a) -> a -- which is to say :: -- forall a. (forall s. (_State s -> (a, _State s))) -> a -_runST a m = case m _RealWorld (S# _RealWorld realWorld#) of - (r :: a, wild :: _State _RealWorld) -> r +runST a m = case m _RealWorld (S# _RealWorld realWorld#) of + (r :: a, wild :: _State _RealWorld) -> r \end{verbatim} + We unfold always, just for simplicity: \begin{code} runSTId - = pcMiscPrelId runSTIdKey pRELUDE_BUILTIN SLIT("_runST") run_ST_ty id_info + = pcMiscPrelId runSTIdKey gHC__ SLIT("runST") run_ST_ty id_info where - s_tv = beta_tv - s = beta + s_tv = betaTyVar + s = betaTy st_ty a = mkSigmaTy [s_tv] [] (mkStateTransformerTy s a) run_ST_ty - = mkSigmaTy [alpha_tv] [] (st_ty alpha `UniFun` alpha) + = mkSigmaTy [alphaTyVar] [] (mkFunTys [st_ty alphaTy] alphaTy) -- NB: rank-2 polymorphism! (forall inside the st_ty...) id_info = noIdInfo `addInfo` mkArityInfo 1 - `addInfo` mkStrictnessInfo [WwStrict] Nothing + `addInfo` mkStrictnessInfo [WwStrict] Nothing + `addInfo` mkArgUsageInfo [ArgUsage 1] -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template) -- see example below {- OUT: [m, t, r, wild] = mkTemplateLocals [ - {-m-} st_ty alpha_ty, + {-m-} st_ty alphaTy, {-t-} realWorldStateTy, - {-r-} alpha_ty, + {-r-} alphaTy, {-_-} realWorldStateTy ] run_ST_template - = CoTyLam alpha_tyvar - (mkCoLam [m] ( - CoLet (CoNonRec t (CoCon stateDataCon [realWorldTy] [CoVarAtom realWorldPrimId])) ( - CoCase (CoApp (mkCoTyApp (CoVar m) realWorldTy) (CoVarAtom t)) ( - CoAlgAlts - [(mkTupleCon 2, [r, wild], CoVar r)] - CoNoDefault)))) + = mkLam [alphaTyVar] [m] ( + Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) ( + Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) ( + AlgAlts + [(mkTupleCon 2, [r, wild], Var r)] + NoDefault))) -} \end{code} -SLPJ 95/04: Why @_runST@ must not have an unfolding; consider: +SLPJ 95/04: Why @runST@ must not have an unfolding; consider: \begin{verbatim} f x = - _runST ( \ s -> let + runST ( \ s -> let (a, s') = newArray# 100 [] s (_, s'') = fill_in_array_or_something a x s' in freezeArray# a s'' ) \end{verbatim} -If we inline @_runST@, we'll get: +If we inline @runST@, we'll get: \begin{verbatim} f x = let (a, s') = newArray# 100 [] realWorld#{-NB-} @@ -554,14 +558,18 @@ f = let All calls to @f@ will share a {\em single} array! End SLPJ 95/04. @realWorld#@ used to be a magic literal, \tr{void#}. If things get -nasty as-is, change it back to a literal (@BasicLit@). +nasty as-is, change it back to a literal (@Literal@). \begin{code} realWorldPrimId - = pcMiscPrelId realWorldPrimIdKey pRELUDE_BUILTIN SLIT("realWorld#") + = pcMiscPrelId realWorldPrimIdKey gHC_BUILTINS SLIT("realWorld#") realWorldStatePrimTy noIdInfo \end{code} +\begin{code} +voidId = pcMiscPrelId voidIdKey gHC_BUILTINS SLIT("void") voidTy noIdInfo +\end{code} + %************************************************************************ %* * \subsection[PrelVals-foldr-build]{Values known about for ``foldr/build''} @@ -570,22 +578,21 @@ realWorldPrimId \begin{code} buildId - = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_build") buildTy - ((((noIdInfo - `addInfo_UF` mkMagicUnfolding SLIT("build")) + = pcMiscPrelId buildIdKey SLIT("GHCerr") SLIT("build") buildTy + ((((noIdInfo + {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-}) `addInfo` mkStrictnessInfo [WwStrict] Nothing) `addInfo` mkArgUsageInfo [ArgUsage 2]) - `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy) + `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy) -- cheating, but since _build never actually exists ... where -- The type of this strange object is: -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] - buildTy = mkSigmaTy [alpha_tv] [] (buildUniTy `UniFun` (mkListTy alpha)) + buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy)) where - buildUniTy = mkSigmaTy [beta_tv] [] - ((alpha `UniFun` (beta `UniFun` beta)) - `UniFun` (beta `UniFun` beta)) + build_ty = mkSigmaTy [betaTyVar] [] + (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy) \end{code} @mkBuild@ is sugar for building a build! @@ -601,63 +608,151 @@ buildId @e@ is the object right inside the @build@ \begin{code} -mkBuild :: UniType +mkBuild :: Type -> TyVar -> Id -> Id -> Id - -> PlainCoreExpr -- template - -> PlainCoreExpr -- template + -> CoreExpr -- template + -> CoreExpr -- template mkBuild ty tv c n g expr - = CoLet (CoNonRec g (CoTyLam tv (mkCoLam [c,n] expr))) - (CoApp (mkCoTyApp (CoVar buildId) ty) (CoVarAtom g)) + = Let (NonRec g (mkLam [tv] [c,n] expr)) + (App (mkTyApp (Var buildId) [ty]) (VarArg g)) \end{code} -mkFoldr ty_a ty_b [x,y...] => foldr ty_a ty_b x y .. +\begin{code} +augmentId + = pcMiscPrelId augmentIdKey SLIT("GHCerr") SLIT("augment") augmentTy + (((noIdInfo + {-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-}) + `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing) + `addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage]) + -- cheating, but since _augment never actually exists ... + where + -- The type of this strange object is: + -- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a] + + augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy)) + where + aug_ty = mkSigmaTy [betaTyVar] [] + (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy) +\end{code} \begin{code} -foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr") +foldrId = pcMiscPrelId foldrIdKey pRELUDE SLIT("foldr") foldrTy idInfo where foldrTy = - mkSigmaTy [alpha_tv, beta_tv] [] - ((alpha `UniFun` (beta `UniFun` beta)) - `UniFun` (beta - `UniFun` ((mkListTy alpha) - `UniFun` beta))) - - idInfo = (((((noIdInfo - `addInfo_UF` mkMagicUnfolding SLIT("foldr")) + mkSigmaTy [alphaTyVar, betaTyVar] [] + (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy) + + idInfo = (((((noIdInfo + {-LATER:`addInfo_UF` mkMagicUnfolding foldrIdKey-}) `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing) `addInfo` mkArityInfo 3) `addInfo` mkUpdateInfo [2,2,1]) - `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy) + `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy) -mkFoldr a b f z xs = foldl CoApp - (mkCoTyApps (CoVar foldrId) [a, b]) - [CoVarAtom f,CoVarAtom z,CoVarAtom xs] - -foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl") +foldlId = pcMiscPrelId foldlIdKey pRELUDE SLIT("foldl") foldlTy idInfo where foldlTy = - mkSigmaTy [alpha_tv, beta_tv] [] - ((alpha `UniFun` (beta `UniFun` alpha)) - `UniFun` (alpha - `UniFun` ((mkListTy beta) - `UniFun` alpha))) - - idInfo = (((((noIdInfo - `addInfo_UF` mkMagicUnfolding SLIT("foldl")) + mkSigmaTy [alphaTyVar, betaTyVar] [] + (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy) + + idInfo = (((((noIdInfo + {-LATER:`addInfo_UF` mkMagicUnfolding foldlIdKey-}) `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing) `addInfo` mkArityInfo 3) `addInfo` mkUpdateInfo [2,2,1]) - `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy) + `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy) + +-- A bit of magic goes no here. We translate appendId into ++, +-- you have to be carefull when you actually compile append: +-- xs ++ ys = augment (\ c n -> foldr c n xs) ys +-- {- unfold augment -} +-- = foldr (:) ys xs +-- {- fold foldr to append -} +-- = ys `appendId` xs +-- = ys ++ xs -- ugg! +-- *BUT* you want (++) and not _append in your interfaces. +-- +-- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside +-- the prelude. +-- +{- OLD: doesn't apply with 1.3 +appendId + = pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo + where + appendTy = + (mkSigmaTy [alphaTyVar] [] + (mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy))) + idInfo = (((noIdInfo + `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing) + `addInfo` mkArityInfo 2) + `addInfo` mkUpdateInfo [1,2]) +-} +\end{code} + +%************************************************************************ +%* * +\subsection[PrelUtils-specialisations]{Specialisations for builtin values} +%* * +%************************************************************************ + +The specialisations which exist for the builtin values must be recorded in +their IdInfos. + +NOTE: THE USES OF THE pcGenerate... FUNCTIONS MUST CORRESPOND + TO THE SPECIALISATIONS DECLARED IN THE PRELUDE !!! + +HACK: We currently use the same unique for the specialised Ids. + +The list @specing_types@ determines the types for which specialised +versions are created. Note: This should correspond with the +types passed to the pre-processor with the -genSPECS arg (see ghc.lprl). -mkFoldl a b f z xs = foldl CoApp - (mkCoTyApps (CoVar foldlId) [a, b]) - [CoVarAtom f,CoVarAtom z,CoVarAtom xs] +ToDo: Create single mkworld definition which is grabbed here and in ghc.lprl -pRELUDE_FB = SLIT("PreludeFoldrBuild") +\begin{code} +pcGenerateSpecs :: Unique -> Id -> IdInfo -> Type -> SpecEnv +pcGenerateSpecs key id info ty + = nullSpecEnv + +{- LATER: + +pc_gen_specs True key id info ty + +pc_gen_specs is_id key id info ty + = mkSpecEnv spec_infos + where + spec_infos = [ let spec_ty = specialiseTy ty spec_tys 0 + spec_id = if is_id + then mkSpecId key {- HACK WARNING: same unique! -} + id spec_tys spec_ty info + else panic "SpecData:SpecInfo:SpecId" + in + SpecInfo spec_tys (length ctxts) spec_id + | spec_tys <- specialisations ] + + (tyvars, ctxts, _) = splitSigmaTy ty + no_tyvars = length tyvars + + specialisations = if no_tyvars == 0 + then [] + else tail (cross_product no_tyvars specing_types) + + -- N.B. tail removes fully polymorphic specialisation + +cross_product 0 tys = [] +cross_product 1 tys = map (:[]) tys +cross_product n tys = concat [map (:cp) tys | cp <- cross_product (n-1) tys] + + +specing_types = [Nothing, + Just charPrimTy, + Just doublePrimTy, + Just intPrimTy ] +-} \end{code}