-- may or may not have a wrapper, depending on whether
-- the wrapper does anything.
- -- *Neither* the worker *nor* the wrapper take the dcStupidTheta dicts as arguments
+ -- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments
-- The wrapper takes dcOrigArgTys as its arguments
-- The worker takes dcRepArgTys as its arguments
= WwLazy -- Argument is lazy as far as we know
MaybeAbsent -- (does not imply worker's existence [etc]).
-- If MaybeAbsent == True, then it is
- -- *definitely* lazy. (NB: Absence implies
+ -- *definitely* lazy. (NB: Absence implies
-- a worker...)
| WwStrict -- Argument is strict but that's all we know
-- If we pretend it is strict then when we see
-- case x of y -> $wMkT y
-- the simplifier thinks that y is "sure to be evaluated" (because
- -- $wMkT is strict) and drops the case. No, $wMkT is not strict.
+ -- $wMkT is strict) and drops the case. No, $wMkT is not strict.
--
-- When the simplifer sees a pattern
-- case e of MkT x -> ...
| Qual Module OccName
-- A qualified name written by the user in
- -- *source* code. The module isn't necessarily
+ -- *source* code. The module isn't necessarily
-- the module where the thing is defined;
-- just the one from which it is imported
CmmLabelOff clbl i -> mkW_ <> pprCLabel clbl <> char '+' <> int i
CmmLabelDiffOff clbl1 clbl2 i
-- WARNING:
- -- * the lit must occur in the info table clbl2
- -- * clbl1 must be an SRT, a slow entry point or a large bitmap
+ -- * the lit must occur in the info table clbl2
+ -- * clbl1 must be an SRT, a slow entry point or a large bitmap
-- The Mangler is expected to convert any reference to an SRT,
-- a slow entry point or a large bitmap
-- from an info table to an offset.
-- ;
CmmNop -> semi
- -- // text
+ -- // text
CmmComment s -> text "//" <+> ftext s
-- reg = expr;
| size >= wORD_SIZE_IN_BITS = complement 0
| otherwise = (1 `shiftL` size) - 1
-{-|
+{- |
Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h.
-Some kinds of bitmap pack a size/bitmap into a single word if
+Some kinds of bitmap pack a size\/bitmap into a single word if
possible, or fall back to an external pointer when the bitmap is too
large. This value represents the largest size of bitmap that can be
packed into a single word.
VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off
; return (CmmLoad sp_rel mach_rep) }
- VirStkLNE sp_off -> getSpRelOffset sp_off ;
+ VirStkLNE sp_off -> getSpRelOffset sp_off
VoidLoc -> return $ pprPanic "idInfoToAmode: void" (ppr (cg_id info))
-- We return a 'bottom' amode, rather than panicing now
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.73 2005/03/18 13:37:38 simonmar Exp $
+% $Id: CgCase.lhs,v 1.74 2005/03/31 10:16:34 simonmar Exp $
%
%********************************************************
%* *
live_in_whole_case live_in_alts bndr srt alt_type alts
| unsafe_foreign_call
= ASSERT( isSingleton alts )
- do -- *must* be an unboxed tuple alt.
+ do -- *must* be an unboxed tuple alt.
-- exactly like the cgInlinePrimOp case for unboxed tuple alts..
{ res_tmps <- mapFCs bindNewToTemp non_void_res_ids
; let res_hints = map (typeHint.idType) non_void_res_ids
\begin{code}
cgAlgAlts :: GCFlag
-> Maybe VirtualSpOffset
- -> AltType -- ** AlgAlt or PolyAlt only **
+ -> AltType -- ** AlgAlt or PolyAlt only **
-> [StgAlt] -- The alternatives
-> FCode ( [(ConTagZ, CgStmts)], -- The branches
Maybe CgStmts ) -- The default case
cgAlgAlt :: GCFlag
-> Maybe VirtualSpOffset -- Turgid state
- -> AltType -- ** AlgAlt or PolyAlt only **
+ -> AltType -- ** AlgAlt or PolyAlt only **
-> StgAlt
-> FCode (AltCon, CgStmts)
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.67 2005/03/18 13:37:40 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.68 2005/03/31 10:16:34 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
-- it in the closure. Instead, just bind it to Node on entry.
-- NB we can be sure that Node will point to it, because we
-- havn't told mkClosureLFInfo about this; so if the binder
- -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
+ -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
-- stored in the closure itself, so it will make sure that
-- Node points to it...
let
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgHeapery.lhs,v 1.44 2005/03/18 13:37:42 simonmar Exp $
+% $Id: CgHeapery.lhs,v 1.45 2005/03/31 10:16:34 simonmar Exp $
%
\section[CgHeapery]{Heap management functions}
= (mkConInfo dflags is_static data_con tot_wds ptr_wds,
things_w_offsets)
where
- (tot_wds, -- #ptr_wds + #nonptr_wds
- ptr_wds, -- #ptr_wds
+ (tot_wds, -- #ptr_wds + #nonptr_wds
+ ptr_wds, -- #ptr_wds
things_w_offsets) = mkVirtHeapOffsets args
\end{code}
\begin{code}
mkVirtHeapOffsets
:: [(CgRep,a)] -- Things to make offsets for
- -> (WordOff, -- *Total* number of words allocated
+ -> (WordOff, -- _Total_ number of words allocated
WordOff, -- Number of words allocated for *pointers*
[(a, VirtualHpOffset)])
-- Things with their offsets from start of
-- <srt slot>
-- <forward vector table>
--
--- * The vector table is only present for vectored returns
+-- * The vector table is only present for vectored returns
--
--- * The SRT slot is only there if either
+-- * The SRT slot is only there if either
-- (a) there is SRT info to record, OR
-- (b) if the return is vectored
-- The latter (b) is necessary so that the vector is in a
= do { info_amode <- getSequelAmode
; stmtC (CmmJump (entryCode info_amode) []) }
-emitVectoredReturnInstr :: CmmExpr -- *Zero-indexed* constructor tag
+emitVectoredReturnInstr :: CmmExpr -- _Zero-indexed_ constructor tag
-> Code
emitVectoredReturnInstr zero_indexed_tag
= do { info_amode <- getSequelAmode
emitPrimOp [] WriteForeignObjOp [fo,addr] live
= stmtC (CmmStore (cmmOffsetW fo fixedHdrSize) addr)
--- #define sizzeofByteArrayzh(r,a) \
+-- #define sizzeofByteArrayzh(r,a) \
-- r = (((StgArrWords *)(a))->words * sizeof(W_))
emitPrimOp [res] SizeofByteArrayOp [arg] live
= stmtC $
CmmLit (mkIntCLit wORD_SIZE)
])
--- #define sizzeofMutableByteArrayzh(r,a) \
+-- #define sizzeofMutableByteArrayzh(r,a) \
-- r = (((StgArrWords *)(a))->words * sizeof(W_))
emitPrimOp [res] SizeofMutableByteArrayOp [arg] live
= emitPrimOp [res] SizeofByteArrayOp [arg] live
--- #define touchzh(o) /* nothing */
+-- #define touchzh(o) /* nothing */
emitPrimOp [] TouchOp [arg] live
= nopC
--- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
+-- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
emitPrimOp [res] ByteArrayContents_Char [arg] live
= stmtC (CmmAssign res (cmmOffsetB arg arrWordsHdrSize))
--- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
+-- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
emitPrimOp [res] StableNameToIntOp [arg] live
= stmtC (CmmAssign res (cmmLoadIndexW arg fixedHdrSize))
--- #define eqStableNamezh(r,sn1,sn2) \
+-- #define eqStableNamezh(r,sn1,sn2) \
-- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
emitPrimOp [res] EqStableNameOp [arg1,arg2] live
= stmtC (CmmAssign res (CmmMachOp mo_wordEq [
emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] live
= stmtC (CmmAssign res (CmmMachOp mo_wordEq [arg1,arg2]))
--- #define addrToHValuezh(r,a) r=(P_)a
+-- #define addrToHValuezh(r,a) r=(P_)a
emitPrimOp [res] AddrToHValueOp [arg] live
= stmtC (CmmAssign res arg)
--- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
+-- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
emitPrimOp [res] DataToTagOp [arg] live
= stmtC (CmmAssign res (getConstrTag arg))
objects, even if they are in old space. When they become immutable,
they can be removed from this scavenge list. -}
--- #define unsafeFreezzeArrayzh(r,a)
+-- #define unsafeFreezzeArrayzh(r,a)
-- {
-- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info);
-- r = a;
= stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)),
CmmAssign res arg ]
--- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
+-- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] live
= stmtC (CmmAssign res arg)
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgTailCall.lhs,v 1.41 2004/11/26 16:20:12 simonmar Exp $
+% $Id: CgTailCall.lhs,v 1.42 2005/03/31 10:16:34 simonmar Exp $
%
%********************************************************
%* *
:: CgIdInfo -- The function
-> [(CgRep,CmmExpr)] -- Args
-> CmmStmts -- Pending simultaneous assignments
- -- *** GUARANTEED to contain only stack assignments.
+ -- *** GUARANTEED to contain only stack assignments.
-> Code
performTailCall fun_info arg_amodes pending_assts
-- -----------------------------------------------------------------------------
-- Return Addresses
--- | We always push the return address just before performing a tail call
+-- We always push the return address just before performing a tail call
-- or return. The reason we leave it until then is because the stack
-- slot that the return address is to go into might contain something
-- useful.
startupHaskell() must supply the name of the init function for the "top"
module in the program, and we don't want to require that this name
has the version and way info appended to it.
- -------------------------------------------------------------------------- */
+ -------------------------------------------------------------------------- */
We initialise the module tree by keeping a work-stack,
* pointed to by Sp
= GenericRep -- GC routines consult sizes in info tbl
Bool -- True <=> This is a static closure. Affects how
-- we garbage-collect it
- !Int -- # ptr words
- !Int -- # non-ptr words
+ !Int -- # ptr words
+ !Int -- # non-ptr words
ClosureType -- closure type
| BlackHoleRep
-- Only local Ids conjured up locally, can have free type variables.
-- (During type checking top-level Ids can have free tyvars)
idFreeTyVars id = tyVarsOfType (idType id)
--- | isLocalId id = tyVarsOfType (idType id)
--- | otherwise = emptyVarSet
+-- | isLocalId id = tyVarsOfType (idType id)
+-- | otherwise = emptyVarSet
idRuleVars ::Id -> VarSet
idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
--
-- Things are *not* OK if:
--
- -- * Unsaturated type app before specialisation has been done;
+ -- * Unsaturated type app before specialisation has been done;
--
- -- * Oversaturated type app after specialisation (eta reduction
+ -- * Oversaturated type app after specialisation (eta reduction
-- may well be happening...);
\begin{code}
-- into h; if we inline f first, while it looks small, then g's
-- wrapper will get inlined later anyway. To avoid this nasty
-- ordering difference, we make (case a of (x,y) -> ...),
- -- *where a is one of the arguments* look free.
+ -- *where a is one of the arguments* look free.
other ->
-}
| otherwise
= case guidance of
- UnfoldNever -> False ;
+ UnfoldNever -> False
UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount
| enough_args && size <= (n_vals_wanted + 1)
computeDiscount n_vals_wanted arg_discounts res_discount arg_infos result_used
-- We multiple the raw discounts (args_discount and result_discount)
-- ty opt_UnfoldingKeenessFactor because the former have to do with
- -- *size* whereas the discounts imply that there's some extra
- -- *efficiency* to be gained (e.g. beta reductions, case reductions)
+ -- *size* whereas the discounts imply that there's some extra
+ -- *efficiency* to be gained (e.g. beta reductions, case reductions)
-- by inlining.
-- we also discount 1 for each argument passed, because these will
exprType (Lit lit) = literalType lit
exprType (Let _ body) = exprType body
exprType (Case _ _ ty alts) = ty
-exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
+exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e
exprType (Note other_note e) = exprType e
exprType (Lam binder expr) = mkPiType binder (exprType expr)
exprType e@(App _ _)
-- reconstruct parallel array pattern
--
--- * don't check for the type only; we need to make sure that we are really
+-- * don't check for the type only; we need to make sure that we are really
-- dealing with one of the fake constructors and not with the real
-- representation
-- we create a list from the array elements and convert them into a list using
-- `PrelPArr.toP'
--
--- * the main disadvantage to this scheme is that `toP' traverses the list
+-- * the main disadvantage to this scheme is that `toP' traverses the list
-- twice: once to determine the length and a second time to put to elements
-- into the array; this inefficiency could be avoided by exposing some of
-- the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so
repC (L loc con_decl)
= do { dsWarn (loc, hang ds_msg 4 (ppr con_decl))
; return (panic "DsMeta:repC") }
- where
+
-- gaw 2004 FIX! Need a case for GadtDecl
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
-- Look up a name that is either locally bound or a global name
--
--- * If it is a global name, generate the "original name" representation (ie,
+-- * If it is a global name, generate the "original name" representation (ie,
-- the <module>:<name> form) for the associated entity
--
lookupLOcc :: Located Name -> DsM (Core TH.Name)
-- Stuff for parallel arrays
--
- -- * the following is to desugar cases over fake constructors for
+ -- * the following is to desugar cases over fake constructors for
-- parallel arrays, which are introduced by `tidy1' in the `PArrPat'
-- case
--
-- Concerning `isPArrFakeAlts':
--
- -- * it is *not* sufficient to just check the type of the type
+ -- * it is *not* sufficient to just check the type of the type
-- constructor, as we have to be careful not to confuse the real
-- representation of parallel arrays with the fake constructors;
-- moreover, a list of alternatives must not mix fake and real
-- Result has only the following HsLits:
-- HsIntPrim, HsCharPrim, HsFloatPrim
-- HsDoublePrim, HsStringPrim ?
--- * HsInteger, HsRat, HsInt can't show up in LitPats,
--- * HsString has been turned into an NPat in tcPat
+-- * HsInteger, HsRat, HsInt can't show up in LitPats,
+-- * HsString has been turned into an NPat in tcPat
-- and we get rid of HsChar right here
tidyLitPat (HsChar c) pat = mkCharLitPat c
tidyLitPat lit pat = pat
let
-- Get the arg reps, zapping the leading Addr# in the dynamic case
- a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
+ a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
| is_static = a_reps_pushed_RAW
| otherwise = if null a_reps_pushed_RAW
then panic "ByteCodeGen.generateCCall: dyn with no args"
-- of making a multiway branch using a switch tree.
-- What a load of hassle!
-mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
+mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
-- a hint; generates better code
-- Nothing is always safe
-> [(Discr, BCInstrList)]
vecret_entry 6 = stg_interp_constr7_entry
vecret_entry 7 = stg_interp_constr8_entry
+#ifndef __HADDOCK__
-- entry point for direct returns for created constr itbls
foreign label "stg_interp_constr_entry" stg_interp_constr_entry :: Ptr ()
-- and the 8 vectored ones
foreign label "stg_interp_constr6_entry" stg_interp_constr6_entry :: Ptr ()
foreign label "stg_interp_constr7_entry" stg_interp_constr7_entry :: Ptr ()
foreign label "stg_interp_constr8_entry" stg_interp_constr8_entry :: Ptr ()
-
+#endif
= vcat [ppr_isrec,
vcat (map ppr sigs),
vcat (map ppr (bagToList binds))
- -- *not* pprLHsBinds because we don't want braces; 'let' and
+ -- *not* pprLHsBinds because we don't want braces; 'let' and
-- 'where' include a list of HsBindGroups and we don't want
-- several groups of bindings each with braces around.
]
-- foreign declarations are distinguished as to whether they define or use a
-- Haskell name
--
--- * the Boolean value indicates whether the pre-standard deprecated syntax
+-- * the Boolean value indicates whether the pre-standard deprecated syntax
-- has been used
--
type LForeignDecl name = Located (ForeignDecl name)
--
data ForeignImport = -- import of a C entity
--
- -- * the two strings specifying a header file or library
+ -- * the two strings specifying a header file or library
-- may be empty, which indicates the absence of a
-- header or object specification (both are not used
-- in the case of `CWrapper' and when `CFunction'
-- has a dynamic target)
--
- -- * the calling convention is irrelevant for code
+ -- * the calling convention is irrelevant for code
-- generation in the case of `CLabel', but is needed
-- for pretty printing
--
- -- * `Safety' is irrelevant for `CLabel' and `CWrapper'
+ -- * `Safety' is irrelevant for `CLabel' and `CWrapper'
--
CImport CCallConv -- ccall or stdcall
Safety -- safe or unsafe
\begin{code}
type ReboundNames id = [(Name, HsExpr id)]
--- * Before the renamer, this list is empty
+-- * Before the renamer, this list is empty
--
--- * After the renamer, it takes the form [(std_name, HsVar actual_name)]
+-- * After the renamer, it takes the form [(std_name, HsVar actual_name)]
-- For example, for the 'return' op of a monad
-- normal case: (GHC.Base.return, HsVar GHC.Base.return)
-- with rebindable syntax: (GHC.Base.return, return_22)
-- where return_22 is whatever "return" is in scope
--
--- * After the type checker, it takes the form [(std_name, <expression>)]
+-- * After the type checker, it takes the form [(std_name, <expression>)]
-- where <expression> is the evidence for the method
\end{code}
%************************************************************************
\begin{code}
-data HsSplice id = HsSplice -- $z or $(f 4)
+data HsSplice id = HsSplice -- $z or $(f 4)
id -- The id is just a unique name to
(LHsExpr id) -- identify this splice point
-- The literal is retained so that the desugarer can readily identify
-- equations with identical literal-patterns
-- Always HsInteger, HsRat or HsString.
- -- *Unlike* NPatIn, for negative literals, the
+ -- *Unlike* NPatIn, for negative literals, the
-- literal is acutally negative!
Type -- Type of pattern, t
(HsExpr id) -- Of type t -> Bool; detects match
data HsTyVarBndr name
= UserTyVar name
| KindedTyVar name Kind
- -- *** NOTA BENE *** A "monotype" in a pragma can have
+ -- *** NOTA BENE *** A "monotype" in a pragma can have
-- for-alls in it, (mostly to do with dictionaries). These
-- must be explicitly Kinded.
-----------------
ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
--- *Excludes* the 'main' name, but *includes* the implicitly-bound names
+-- *Excludes* the 'main' name, but *includes* the implicitly-bound names
-- Deeply revolting, because it has to predict what gets bound,
-- especially the question of whether there's a wrapper for a datacon
FloatSinhOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Sinh(float64) conv.r4")
FloatCoshOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Cosh(float64) conv.r4")
FloatTanhOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Tanh(float64) conv.r4")
- FloatPowerOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Pow(float64, float64) conv.r4") -- ** op, make use of implicit cast to r8...
+ FloatPowerOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Pow(float64, float64) conv.r4") -- ** op, make use of implicit cast to r8...
DoubleExpOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Exp(float64)")
DoubleLogOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Log(float64)")
-- to store an access to this thing.
-- So variables might be Int or Object.
- -- ** method calls store the returned
- -- ** type, not a complete arg x result type.
+ -- ** method calls store the returned
+ -- ** type, not a complete arg x result type.
--
-- Thinking:
-- ... foo1.foo2(...).foo3 ...
LifterM { unLifterM ::
TypeName -> -- this class name
Int -> -- uniq supply
- ( a -- *
+ ( a -- *
, Frees -- frees
, [Decl] -- lifted classes
, Int -- The uniqs
-----------------------------------------------------------------------------
--- $Id: DriverPhases.hs,v 1.35 2005/03/18 13:39:05 simonmar Exp $
+-- $Id: DriverPhases.hs,v 1.36 2005/03/31 10:16:38 simonmar Exp $
--
-- GHC Driver
--
| otherwise -- Normal Haskell source files
-> do
- let
maybe_stub_o <- compileStub dflags' stub_c_exists
let stub_unlinked = case maybe_stub_o of
Nothing -> []
pgm_l :: (String,[Option]),
pgm_dll :: (String,[Option]),
- -- ** Package flags
+ -- ** Package flags
extraPkgConfs :: [FilePath],
-- The -package-conf flags given on the command line, in the order
-- they appeared.
packageFlags :: [PackageFlag],
-- The -package and -hide-package flags from the command-line
- -- ** Package state
+ -- ** Package state
pkgState :: PackageState,
-- hsc dynamic flags
dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc,
showPass,
- -- * Messages during compilation
+ -- * Messages during compilation
setMsgHandler,
putMsg,
compilationProgressMsg,
addTarget,
guessTarget,
- -- * Loading/compiling the program
+ -- * Loading\/compiling the program
depanal,
load, SuccessFlag(..), -- also does depanal
workingDirectoryChanged,
-- | Starts a new session. A session consists of a set of loaded
-- modules, a set of options (DynFlags), and an interactive context.
--- ToDo: GhcMode should say "keep typechecked code" and/or "keep renamed
+-- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
-- code".
newSession :: GhcMode -> IO Session
newSession mode = do
-- | Sets the targets for this session. Each target may be a module name
-- or a filename. The targets correspond to the set of root modules for
--- the program/library. Unloading the current program is achieved by
+-- the program\/library. Unloading the current program is achieved by
-- setting the current set of targets to be empty, followed by load.
setTargets :: Session -> [Target] -> IO ()
setTargets s targets = modifySession s (\h -> h{ hsc_targets = targets })
hscMain, newHscEnv, hscCmmFile,
hscBufferCheck, hscFileCheck,
#ifdef GHCI
- , hscStmt, hscTcExpr, hscKcType
- , hscGetInfo, GetInfoResult
- , compileExpr
+ hscStmt, hscTcExpr, hscKcType,
+ hscGetInfo, GetInfoResult,
+ compileExpr,
#endif
) where
source_unchanged have_object maybe_old_iface
= do {
(recomp_reqd, maybe_checked_iface) <-
- _scc_ "checkOldIface"
+ {-# SCC "checkOldIface" #-}
checkOldIface hsc_env mod_summary
source_unchanged maybe_old_iface;
= do { compilationProgressMsg (hsc_dflags hsc_env) $
("Skipping " ++ showModMsg have_object mod_summary)
- ; new_details <- _scc_ "tcRnIface"
+ ; new_details <- {-# SCC "tcRnIface" #-}
typecheckIface hsc_env old_iface ;
; dumpIfaceStats hsc_env
-------------------
-- RENAME and TYPECHECK
-------------------
- ; (tc_msgs, maybe_tc_result) <- _scc_ "TypeCheck"
+ ; (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-}
tcRnExtCore hsc_env rdr_module
; msg_act tc_msgs
; case maybe_tc_result of
-- RENAME and TYPECHECK
-------------------
(tc_msgs, maybe_tc_result)
- <- _scc_ "Typecheck-Rename"
+ <- {-# SCC "Typecheck-Rename" #-}
tcRnModule hsc_env (ms_hsc_src mod_summary) rdr_module
; msg_act tc_msgs
-------------------
-- DESUGAR
-------------------
- ; (warns, maybe_ds_result) <- _scc_ "DeSugar"
+ ; (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
deSugar hsc_env tc_result
; msg_act (warns, emptyBag)
; case maybe_ds_result of
hscBootBackEnd hsc_env mod_summary maybe_checked_iface Nothing
= return HscFail
hscBootBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result)
- = do { final_iface <- _scc_ "MkFinalIface"
+ = do { final_iface <- {-# SCC "MkFinalIface" #-}
mkIface hsc_env (ms_location mod_summary)
maybe_checked_iface ds_result
-------------------
-- FLATTENING
-------------------
- ; flat_result <- _scc_ "Flattening"
+ ; flat_result <- {-# SCC "Flattening" #-}
flatten hsc_env ds_result
-------------------
-- SIMPLIFY
-------------------
- ; simpl_result <- _scc_ "Core2Core"
+ ; simpl_result <- {-# SCC "Core2Core" #-}
core2core hsc_env flat_result
-------------------
-- TIDY
-------------------
- ; tidy_result <- _scc_ "CoreTidy"
+ ; tidy_result <- {-# SCC "CoreTidy" #-}
tidyCorePgm hsc_env simpl_result
-- Emit external core
-- This has to happen *after* code gen so that the back-end
-- info has been set. Not yet clear if it matters waiting
-- until after code output
- ; new_iface <- _scc_ "MkFinalIface"
+ ; new_iface <- {-# SCC "MkFinalIface" #-}
mkIface hsc_env (ms_location mod_summary)
maybe_checked_iface tidy_result
hscBufferTypecheck hsc_env rdr_module msg_act
hscBufferTypecheck hsc_env rdr_module msg_act = do
- (tc_msgs, maybe_tc_result) <- _scc_ "Typecheck-Rename"
+ (tc_msgs, maybe_tc_result) <- {-# SCC "Typecheck-Rename" #-}
tcRnModule hsc_env HsSrcFile rdr_module
msg_act tc_msgs
case maybe_tc_result of
-------------------
-- PREPARE FOR CODE GENERATION
-- Do saturation and convert to A-normal form
- prepd_binds <- _scc_ "CorePrep"
+ prepd_binds <- {-# SCC "CorePrep" #-}
corePrepPgm dflags core_binds type_env;
case hscTarget dflags of
other ->
do
----------------- Convert to STG ------------------
- (stg_binds, cost_centre_info) <- _scc_ "CoreToStg"
+ (stg_binds, cost_centre_info) <- {-# SCC "CoreToStg" #-}
myCoreToStg dflags this_mod prepd_binds
------------------ Code generation ------------------
- abstractC <- _scc_ "CodeGen"
+ abstractC <- {-# SCC "CodeGen" #-}
codeGen dflags this_mod type_env foreign_stubs
dir_imps cost_centre_info stg_binds
myParseModule dflags src_filename maybe_src_buf
- = do -------------------------- Parser ----------------
- showPass dflags "Parser"
- _scc_ "Parser" do
+ = -------------------------- Parser ----------------
+ showPass dflags "Parser" >>
+ {-# SCC "Parser" #-} do
-- sometimes we already have the buffer in memory, perhaps
-- because we needed to parse the imports out of it, or get the
myCoreToStg dflags this_mod prepd_binds
= do
- stg_binds <- _scc_ "Core2Stg"
+ stg_binds <- {-# SCC "Core2Stg" #-}
coreToStg dflags prepd_binds
- (stg_binds2, cost_centre_info) <- _scc_ "Core2Stg"
+ (stg_binds2, cost_centre_info) <- {-# SCC "Core2Stg" #-}
stg2stg dflags this_mod stg_binds
return (stg_binds2, cost_centre_info)
-- Nothing => Parse error (message already printed)
-- Just x => success
hscParseThing parser dflags str
- = do showPass dflags "Parser"
- _scc_ "Parser" do
+ = showPass dflags "Parser" >>
+ {-# SCC "Parser" #-} do
buf <- stringToStringBuffer str
data Target = Target TargetId (Maybe (StringBuffer,ClockTime))
data TargetId
- = TargetModule Module -- | A module name: search for the file
- | TargetFile FilePath -- | A filename: parse it to find the module name.
+ = TargetModule Module -- ^ A module name: search for the file
+ | TargetFile FilePath -- ^ A filename: parse it to find the module name.
pprTarget :: Target -> SDoc
--
when (not (null overlaps)) $ overlappingError pkg overlaps
--
- let
return (addListToUFM modmap
[(m, (pkg, m `elem` exposed_mods))
| m <- all_mods])
-----------------------------------------------------------------------------
-- Define getBaseDir :: IO (Maybe String)
-#if defined(mingw32_HOST_OS)
getBaseDir :: IO (Maybe String)
+#if defined(mingw32_HOST_OS)
-- Assuming we are running ghc, accessed by path $()/bin/ghc.exe,
-- return the path $(stuff). Note that we drop the "bin/" directory too.
getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
foreign import stdcall unsafe "GetModuleFileNameA"
getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
-getBaseDir :: IO (Maybe String) = do return Nothing
+getBaseDir = return Nothing
#endif
#ifdef mingw32_HOST_OS
extendUExpr I32 x = x
extendUExpr rep x = CmmMachOp (MO_U_Conv rep I32) [x]
--- ###FIXME: exact code duplication from x86 case
+-- ###FIXME: exact code duplication from x86 case
-- The dual to getAnyReg: compute an expression into a register, but
-- we don't mind which one it is.
getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
#endif /* sparc_TARGET_ARCH */
#if powerpc_TARGET_ARCH
--- ###FIXME: I16 and I8!
+-- ###FIXME: I16 and I8!
condIntCode cond x (CmmLit (CmmInt y rep))
| Just src2 <- makeImmediate rep (not $ condUnsigned cond) y
= do
| PUSH MachRep Operand
| POP MachRep Operand
-- both unused (SDM):
- -- | PUSHA
- -- | POPA
+ -- | PUSHA
+ -- | POPA
-- Jumping around.
| JMP Operand
is_G_instr :: Instr -> Bool
is_G_instr instr
= case instr of
- GMOV _ _ -> True; GLD _ _ _ -> True; GST _ _ _ -> True;
- GLDZ _ -> True; GLD1 _ -> True;
- GFTOI _ _ -> True; GDTOI _ _ -> True;
- GITOF _ _ -> True; GITOD _ _ -> True;
+ GMOV _ _ -> True; GLD _ _ _ -> True; GST _ _ _ -> True
+ GLDZ _ -> True; GLD1 _ -> True
+ GFTOI _ _ -> True; GDTOI _ _ -> True
+ GITOF _ _ -> True; GITOD _ _ -> True
GADD _ _ _ _ -> True; GDIV _ _ _ _ -> True
GSUB _ _ _ _ -> True; GMUL _ _ _ _ -> True
GCMP _ _ _ -> True; GABS _ _ _ -> True
GNEG _ _ _ -> True; GSQRT _ _ _ -> True
- GSIN _ _ _ -> True; GCOS _ _ _ -> True; GTAN _ _ _ -> True;
+ GSIN _ _ _ -> True; GCOS _ _ _ -> True; GTAN _ _ _ -> True
GFREE -> panic "is_G_instr: GFREE (!)"
other -> False
callerSaves _ = False
--- | Returns 'Nothing' if this global register is not stored
+-- | Returns 'Nothing' if this global register is not stored
-- in a real machine register, otherwise returns @'Just' reg@, where
-- reg is the machine register it is stored in.
-- Mach-O (Darwin, Mac OS X)
--
-- Indirect access is required in the following cases:
--- * things imported from a dynamic library
--- * things from a different module, if we're generating PIC code
+-- * things imported from a dynamic library
+-- * things from a different module, if we're generating PIC code
-- It is always possible to access something indirectly,
-- even when it's not necessary.
-- this is a list of names that need to be available if flattening is
-- performed (EXPORTED)
--
--- * needs to be kept in sync with the names used in Core generation in
+-- * needs to be kept in sync with the names used in Core generation in
-- `FlattenMonad' and `NDPCoreUtils'
--
namesNeededForFlattening :: FreeVars
-- extend the parallel context by the given set of variables (EXPORTED)
--
--- * if there is no parallel context at the moment, the first element of the
+-- * if there is no parallel context at the moment, the first element of the
-- variable list will be used to determine the new parallel context
--
--- * the second argument is executed in the current context extended with the
+-- * the second argument is executed in the current context extended with the
-- given variables
--
--- * the variables must already have been lifted by transforming their type,
+-- * the variables must already have been lifted by transforming their type,
-- but they *must* have retained their original name (or, at least, their
-- unique); this is needed so that they match the original variable in
-- variable environments
--
--- * any trace of the given set of variables has to be removed from the state
+-- * any trace of the given set of variables has to be removed from the state
-- at the end of this operation
--
extendContext :: [Var] -> Flatten a -> Flatten a
-- execute the second argument in a restricted context (EXPORTED)
--
--- * all variables in the current parallel context are packed according to
+-- * all variables in the current parallel context are packed according to
-- the permutation vector associated with the variable passed as the first
-- argument (ie, all elements of vectorised context variables that are
-- invalid in the restricted context are dropped)
--
--- * the returned list of core binders contains the operations that perform
+-- * the returned list of core binders contains the operations that perform
-- the restriction on all variables in the parallel context that *do* occur
-- during the execution of the second argument (ie, `liftVar' is executed at
-- least once on any such variable)
-- lift a single variable in the current context (EXPORTED)
--
--- * if the variable does not occur in the context, it's value is vectorised to
+-- * if the variable does not occur in the context, it's value is vectorised to
-- match the size of the current context
--
--- * otherwise, the variable is replaced by whatever the context environment
+-- * otherwise, the variable is replaced by whatever the context environment
-- maps it to (this may either be simply the lifted version of the original
-- variable or a packed variant of that variable)
--
--- * the monad keeps track of all lifted variables that occur in the parallel
+-- * the monad keeps track of all lifted variables that occur in the parallel
-- context, so that `packContext' can determine the correct set of core
-- bindings
--
-- lift a constant expression in the current context (EXPORTED)
--
--- * the value of the constant expression is vectorised to match the current
+-- * the value of the constant expression is vectorised to match the current
-- parallel context
--
liftConst :: CoreExpr -> Flatten CoreExpr
-- pick those variables of the given set that occur (if albeit in lifted form)
-- in the current parallel context (EXPORTED)
--
--- * the variables returned are from the given set and *not* the corresponding
+-- * the variables returned are from the given set and *not* the corresponding
-- context variables
--
intersectWithContext :: VarSet -> Flatten [Var]
where
tc = tyConAppTyCon ty
--
- neqName {- | name == charPrimTyConName = neqCharName -}
+ neqName {- | name == charPrimTyConName = neqCharName -}
| tc == intPrimTyCon = primOpId IntNeOp
- {- | name == floatPrimTyConName = neqFloatName -}
- {- | name == doublePrimTyConName = neqDoubleName -}
+ {- | name == floatPrimTyConName = neqFloatName -}
+ {- | name == doublePrimTyConName = neqDoubleName -}
| otherwise =
pprPanic "FlattenMonad.mk'neq: " (ppr ty)
-- get the `Id' of a known `Name'
--
--- * this can be the `Name' of any function that's visible on the toplevel of
+-- * this can be the `Name' of any function that's visible on the toplevel of
-- the current compilation unit
--
lookupName :: Name -> Flatten Id
-- create a back-permute binder
--
--- * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a
+-- * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a
-- Core binding of the form
--
-- x = bpermuteDftP indexArrayVar srcArrayVar dftArrayVar
-- for a type of the form `[:t:]', yield `t' (EXPORTED)
--
--- * if the type has any other form, a fatal error occurs
+-- * if the type has any other form, a fatal error occurs
--
parrElemTy :: Type -> Type
parrElemTy ty =
-- make a tuple construction expression from a list of argument types and
-- argument values (EXPORTED)
--
--- * the two lists need to be of the same length
+-- * the two lists need to be of the same length
--
mkTuple :: [Type] -> [CoreExpr] -> CoreExpr
mkTuple [] [] = Var unitDataConId
'\10' -> cSpace -- \n (not allowed in strings, so !cAny)
'\11' -> cAny + cSpace -- \v
'\12' -> cAny + cSpace -- \f
- '\13' -> cAny + cSpace -- ^M
+ '\13' -> cAny + cSpace -- ^M
'\14' -> 0 -- \016
'\15' -> 0 -- \017
'\16' -> 0 -- \020
'\32' -> cAny + cSpace --
'\33' -> cAny + cSymbol -- !
'\34' -> cAny -- "
- '\35' -> cAny + cSymbol -- #
- '\36' -> cAny + cSymbol -- $
+ '\35' -> cAny + cSymbol -- #
+ '\36' -> cAny + cSymbol -- $
'\37' -> cAny + cSymbol -- %
'\38' -> cAny + cSymbol -- &
'\39' -> cAny + cIdent -- '
'\40' -> cAny -- (
'\41' -> cAny -- )
- '\42' -> cAny + cSymbol -- *
+ '\42' -> cAny + cSymbol -- *
'\43' -> cAny + cSymbol -- +
'\44' -> cAny -- ,
'\45' -> cAny + cSymbol -- -
'\46' -> cAny + cSymbol -- .
- '\47' -> cAny + cSymbol -- /
+ '\47' -> cAny + cSymbol -- /
'\48' -> cAny + cIdent + cDigit -- 0
'\49' -> cAny + cIdent + cDigit -- 1
'\50' -> cAny + cIdent + cDigit -- 2
'\91' -> cAny -- [
'\92' -> cAny + cSymbol -- backslash
'\93' -> cAny -- ]
- '\94' -> cAny + cSymbol -- ^
+ '\94' -> cAny + cSymbol -- ^
'\95' -> cAny + cIdent + cLower -- _
'\96' -> cAny -- `
'\97' -> cAny + cIdent + cLower -- a
'\121' -> cAny + cIdent + cLower -- y
'\122' -> cAny + cIdent + cLower -- z
'\123' -> cAny -- {
- '\124' -> cAny + cSymbol -- |
+ '\124' -> cAny + cSymbol -- |
'\125' -> cAny -- }
'\126' -> cAny + cSymbol -- ~
'\127' -> 0 -- \177
| ITprimdouble Rational
-- MetaHaskell extension tokens
- | ITopenExpQuote -- [| or [e|
- | ITopenPatQuote -- [p|
- | ITopenDecQuote -- [d|
- | ITopenTypQuote -- [t|
- | ITcloseQuote -- |]
- | ITidEscape FastString -- $x
- | ITparenEscape -- $(
- | ITvarQuote -- '
- | ITtyQuote -- ''
+ | ITopenExpQuote -- [| or [e|
+ | ITopenPatQuote -- [p|
+ | ITopenDecQuote -- [d|
+ | ITopenTypQuote -- [t|
+ | ITcloseQuote -- |]
+ | ITidEscape FastString -- $x
+ | ITparenEscape -- $(
+ | ITvarQuote -- '
+ | ITtyQuote -- ''
-- Arrow notation extension
| ITproc
| ITrec
- | IToparenbar -- (|
- | ITcparenbar -- |)
- | ITlarrowtail -- -<
- | ITrarrowtail -- >-
- | ITLarrowtail -- -<<
- | ITRarrowtail -- >>-
+ | IToparenbar -- (|
+ | ITcparenbar -- |)
+ | ITlarrowtail -- -<
+ | ITrarrowtail -- >-
+ | ITLarrowtail -- -<<
+ | ITRarrowtail -- >>-
| ITunknown String -- Used when the lexer can't make sense of it
| ITeof -- end of file token
findSplice, mkGroup,
-- Stuff to do with Foreign declarations
- , CallConv(..)
- , mkImport -- CallConv -> Safety
+ CallConv(..),
+ mkImport, -- CallConv -> Safety
-- -> (FastString, RdrName, RdrNameHsType)
-- -> P RdrNameHsDecl
- , mkExport -- CallConv
+ mkExport, -- CallConv
-- -> (FastString, RdrName, RdrNameHsType)
-- -> P RdrNameHsDecl
- , mkExtName -- RdrName -> CLabelString
+ mkExtName, -- RdrName -> CLabelString
-- Bunch of functions in the parser monad for
-- checking and constructing values
- , checkPrecP -- Int -> P Int
- , checkContext -- HsType -> P HsContext
- , checkPred -- HsType -> P HsPred
- , checkTyClHdr
- , checkSynHdr
- , checkInstType -- HsType -> P HsType
- , checkPattern -- HsExp -> P HsPat
- , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
- , checkDo -- [Stmt] -> P [Stmt]
- , checkMDo -- [Stmt] -> P [Stmt]
- , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
- , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
- , parseError -- String -> Pa
+ checkPrecP, -- Int -> P Int
+ checkContext, -- HsType -> P HsContext
+ checkPred, -- HsType -> P HsPred
+ checkTyClHdr,
+ checkSynHdr,
+ checkInstType, -- HsType -> P HsType
+ checkPattern, -- HsExp -> P HsPat
+ checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
+ checkDo, -- [Stmt] -> P [Stmt]
+ checkMDo, -- [Stmt] -> P [Stmt]
+ checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
+ checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
+ parseError, -- String -> Pa
) where
#include "HsVersions.h"
\begin{code}
--- | Groups together bindings for a single function
+-- | Groups together bindings for a single function
cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
cvTopDecls decls = go (fromOL decls)
where
\begin{code}
ghcPrimExports :: [RdrAvailInfo]
+ghcPrimExports
= map (Avail . nameOccName . idName) ghcPrimIds ++
map (Avail . primOpOcc) allThePrimOps ++
[ AvailTC occ [occ] |
composeAIdKey = mkPreludeMiscIdUnique 120 -- >>>
firstAIdKey = mkPreludeMiscIdUnique 121
appAIdKey = mkPreludeMiscIdUnique 122
-choiceAIdKey = mkPreludeMiscIdUnique 123 -- |||
+choiceAIdKey = mkPreludeMiscIdUnique 123 -- |||
loopAIdKey = mkPreludeMiscIdUnique 124
---------------- Template Haskell -------------------
-- represents the type constructor of parallel arrays
--
--- * this must match the definition in `PrelPArr'
+-- * this must match the definition in `PrelPArr'
--
-- NB: Although the constructor is given here, it will not be accessible in
-- user code as it is not in the environment of any compiled module except
-- fake array constructors
--
--- * these constructors are never really used to represent array values;
+-- * these constructors are never really used to represent array values;
-- however, they are very convenient during desugaring (and, in particular,
-- in the pattern matching compiler) to treat array pattern just like
-- yet another constructor pattern
Nothing ->
-- We allow qualified names on the command line to refer to
- -- *any* name exported by any module in scope, just as if
+ -- *any* name exported by any module in scope, just as if
-- there was an "import qualified M" declaration for every
-- module.
getModule `thenM` \ mod ->
mappM new_tc tycl_decls `thenM` \ tc_avails ->
-- In a hs-boot file, the value binders come from the
- -- *signatures*, and there should be no foreign binders
+ -- *signatures*, and there should be no foreign binders
tcIsHsBoot `thenM` \ is_hs_boot ->
let val_bndrs | is_hs_boot = sig_hs_bndrs
| otherwise = for_hs_bndrs ++ val_hs_bndrs
get_item item@(IEThingAbs n)
| want_hiding -- hiding( C )
-- Here the 'C' can be a data constructor
- -- *or* a type/class, or even both
+ -- *or* a type/class, or even both
= case concat [check_item item, check_item (IEVar data_n)] of
[] -> bale_out item
names -> succeed_with True names
nonrec_rhs = origLams local_body
-- HACK! The following is a fake SysLocal binder with
- -- *the same* unique as binder.
+ -- *the same* unique as binder.
-- the reason for this is the following:
-- this binder *will* get inlined but if it happen to be
-- a top level binder it is never removed as dead code,
end_pass us2 "StgStats" ccs binds
StgDoMassageForProfiling ->
- _scc_ "ProfMassage"
+ {-# SCC "ProfMassage" #-}
let
(collected_CCs, binds3)
= stgMassageForProfiling dflags module_name us1 binds
|| not (all isClassPred theta)
-- Only specialise if all overloading is on class params.
-- In ptic, with implicit params, the type args
- -- *don't* say what the value of the implicit param is!
+ -- *don't* say what the value of the implicit param is!
|| not (spec_tys `lengthIs` n_tyvars)
|| not ( dicts `lengthIs` n_dicts)
|| maybeToBool (lookupRule (\act -> True) (substInScope subst) emptyRuleBase f args)
lintStgBindings :: String -> [StgBinding] -> [StgBinding]
lintStgBindings whodunnit binds
- = _scc_ "StgLint"
+ = {-# SCC "StgLint" #-}
case (initL (lint_binds binds)) of
Nothing -> binds
Just msg -> pprPanic "" (vcat [
| StgLetNoEscape -- remember: ``advanced stuff''
(GenStgLiveVars occ) -- Live in the whole let-expression
-- Mustn't overwrite these stack slots
- -- *Doesn't* include binders of the let(rec).
+ -- *Doesn't* include binders of the let(rec).
(GenStgLiveVars occ) -- Live in the right hand sides (only)
-- These are the ones which must be saved on
-- the stack if they aren't there already
- -- *Does* include binders of the let(rec) if recursive.
+ -- *Does* include binders of the let(rec) if recursive.
(GenStgBinding bndr occ) -- right hand sides (see below)
(GenStgExpr bndr occ) -- body
-------------------------
-- Consider (if x then y else []) with demand V
-- Then the first branch gives {y->V} and the second
--- *implicitly* has {y->A}. So we must put {y->(V `lub` A)}
+-- *implicitly* has {y->A}. So we must put {y->(V `lub` A)}
-- in the result env.
lubType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
= DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubRes` r2)
| AbsBot -- An expression whose abstract value is
-- AbsBot is sure to fail to terminate.
-- AbsBot represents the abstract
- -- *function* bottom too.
+ -- *function* bottom too.
| AbsProd [AbsVal] -- (Lifted) product of abstract values
-- "Lifted" means that AbsBot is *different* from
\begin{code}
mkWWstr :: [Var] -- Wrapper args; have their demand info on them
- -- *Includes type variables*
+ -- *Includes type variables*
-> UniqSM ([Var], -- Worker args
CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
-- and without its lambdas
-- not overlap with anything in the things being looked up
-- (since we do unification).
-- We use tcSkolType because we don't want to allocate fresh
- -- *meta* type variables.
+ -- *meta* type variables.
(tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun)
; let (cls, tys') = tcSplitDFunHead tau'
dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
\begin{code}
mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]
-arrowTyConKind :: Kind -- *->*->*
+arrowTyConKind :: Kind -- *->*->*
arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
\end{code}
topIdLvl :: Id -> ThLevel
-- Globals may either be imported, or may be from an earlier "chunk"
-- (separated by declaration splices) of this module. The former
--- *can* be used inside a top-level splice, but the latter cannot.
+-- *can* be used inside a top-level splice, but the latter cannot.
-- Hence we give the former impLevel, but the latter topLevel
-- E.g. this is bad:
-- x = [| foo |]
emptyLHsBinds
(nlHsVar data_type_name)
- ------------ $dT
+ ------------ $dT
data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
datatype_bind = mkVarBind
constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
- ------------ $cT1 etc
+ ------------ $cT1 etc
mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
mk_con_bind dc = mkVarBind
tycon_loc
kind = tyVarKind tv
(args,res) = splitKindFunTys kind
- tycon | kind == tyConKind listTyCon -- *->*
+ tycon | kind == tyConKind listTyCon -- *->*
= listTyCon -- No tuples this size
| all isLiftedTypeKind args && isLiftedTypeKind res
- = tupleTyCon Boxed (length args) -- *-> ... ->*->*
+ = tupleTyCon Boxed (length args) -- *-> ... ->*->*
| otherwise
= pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
\begin{code}
data TcSigInfo
= TcSigInfo {
- sig_id :: TcId, -- *Polymorphic* binder for this value...
+ sig_id :: TcId, -- *Polymorphic* binder for this value...
sig_scoped :: [Name], -- Names for any scoped type variables
-- Invariant: correspond 1-1 with an initial
-- Look up a RdrName and return all the TyThings it might be
-- A capitalised RdrName is given to us in the DataName namespace,
-- but we want to treat it as *both* a data constructor
--- *and* as a type or class constructor;
+-- *and* as a type or class constructor;
-- hence the call to dataTcOccs, and we return up to two results
tcRnGetInfo hsc_env ictxt rdr_name
= initTcPrintErrors hsc_env iNTERACTIVE $
ArrCtxt {proc_level = curr_lvl + 1, proc_banned = curr_lvl : banned}
getBannedProcLevels :: TcM [ProcLevel]
+getBannedProcLevels
= do { env <- getLclEnv; return (proc_banned (tcl_arrow_ctxt env)) }
incProcLevel :: TcM a -> TcM a
-- See the 'lhs_dicts' in tcSimplifyAndCheck for the RHS
-- We initially quantify over any tyvars free in *either* the rule
- -- *or* the bound variables. The latter is important. Consider
+ -- *or* the bound variables. The latter is important. Consider
-- ss (x,(y,z)) = (x,z)
-- RULE: forall v. fst (ss v) = fst v
-- The type of the rhs of the rule is just a, but v::(a,(b,c))
isAvailable :: Avails -> Inst -> Maybe Avail
isAvailable avails wanted = lookupFM avails wanted
-- NB 1: the Ord instance of Inst compares by the class/type info
- -- *not* by unique. So
+ -- *not* by unique. So
-- d1::C Int == d2::C Int
addLinearAvailable :: Avails -> Avail -> Inst -> TcM (Avails, [Inst])
-> do {
mb_name <- lookupSrcOcc_maybe rdr_name
; case mb_name of
- Just name -> return name ;
+ Just name -> return name
Nothing -> failWithTc (notInScope th_name) }
}
where
-- tcLookup, failure is a bug.
tcLookupTh name
= do { (gbl_env, lcl_env) <- getEnvs
- ; case lookupNameEnv (tcl_env lcl_env) name of
- Just thing -> returnM thing
+ ; case lookupNameEnv (tcl_env lcl_env) name of {
+ Just thing -> returnM thing;
Nothing -> do
{ if nameIsLocalOrFrom (tcg_mod gbl_env) name
then -- It's defined in this module
; return (AGlobal thing) }
-- Imported names should always be findable;
-- if not, we fail hard in tcImportDecl
- }}}
+ }}}}
mk_uniq :: Int# -> Unique
mk_uniq u = mkUniqueGrimily (I# u)
\begin{code}
data Kind
- = LiftedTypeKind -- *
+ = LiftedTypeKind -- *
| OpenTypeKind -- ?
- | UnliftedTypeKind -- #
+ | UnliftedTypeKind -- #
| UbxTupleKind -- (##)
| ArgTypeKind -- ??
| FunKind Kind Kind -- k1 -> k2
algTcFields :: [(FieldLabel, Type, Id)],
-- Its fields (empty if none):
- -- * field name
- -- * its type (scoped over tby tyConTyVars)
- -- * record selector (name = field name)
+ -- * field name
+ -- * its type (scoped over tby tyConTyVars)
+ -- * record selector (name = field name)
algTcRhs :: AlgTyConRhs, -- Data constructors in here
-- First apply env1 to the range of env2
-- Then combine the two, making sure that env1 loses if
-- both bind the same variable; that's why env1 is the
- -- *left* argument to plusVarEnv, because the right arg wins
+ -- *left* argument to plusVarEnv, because the right arg wins
where
subst1 = TvSubst in_scope env1
-- (or NoteTy of these)
| TyConApp -- Application of a TyCon, including newtypes
- TyCon -- *Invariant* saturated appliations of FunTyCon and
+ TyCon -- *Invariant* saturated appliations of FunTyCon and
-- synonyms have their own constructors, below.
-- However, *unsaturated* type synonyms, and FunTyCons
-- do appear as TyConApps. (Unsaturated type synonyms
else GT
))
+#ifndef __HADDOCK__
foreign import ccall "ghc_memcmp" unsafe
memcmp :: ByteArray# -> ByteArray# -> Int# -> IO Int
+#endif
-- -----------------------------------------------------------------------------
-- Outputting 'FastString's
bottom = panic "emptyFM"
-}
--- #define EmptyFM (Branch _ _ IF_GHC(0#,0) _ _)
+-- #define EmptyFM (Branch _ _ IF_GHC(0#,0) _ _)
unitFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM
panic x = Exception.throwDyn (Panic x)
pgmError x = Exception.throwDyn (ProgramError x)
--- #-versions because panic can't return an unboxed int, and that's
+-- #-versions because panic can't return an unboxed int, and that's
-- what TAG_ is with GHC at the moment. Ugh. (Simon)
-- No, man -- Too Beautiful! (Will)
module StringBuffer
(
StringBuffer(..),
- -- non-abstract for vs/HaskellService
+ -- non-abstract for vs\/HaskellService
- -- * Creation/destruction
+ -- * Creation\/destruction
hGetStringBuffer, -- :: FilePath -> IO StringBuffer
stringToStringBuffer, -- :: String -> IO StringBuffer
-- * Moving
stepOn, stepOnBy,
- -- * Conversion
+ -- * Conversion
lexemeToString, -- :: StringBuffer -> Int -> String
lexemeToFastString, -- :: StringBuffer -> Int -> FastString
-- * Parsing integers
- parseInteger,
+ parseInteger,
) where
#include "HsVersions.h"
-- t1 t2 t1' t2' t1 t2 + j'
-- / \
-- t1' t2'
- mix_branches (LeftRoot Leftt) -- | trace "LL" True
+ mix_branches (LeftRoot Leftt) -- | trace "LL" True
= mkSLNodeUFM
(NodeUFMData j p)
(mix_trees t1 right_t)
t2
- mix_branches (LeftRoot Rightt) -- | trace "LR" True
+ mix_branches (LeftRoot Rightt) -- | trace "LR" True
= mkLSNodeUFM
(NodeUFMData j p)
t1
(mix_trees t2 right_t)
- mix_branches (RightRoot Leftt) -- | trace "RL" True
+ mix_branches (RightRoot Leftt) -- | trace "RL" True
= mkSLNodeUFM
(NodeUFMData j' p')
(mix_trees left_t t1')
t2'
- mix_branches (RightRoot Rightt) -- | trace "RR" True
+ mix_branches (RightRoot Rightt) -- | trace "RR" True
= mkLSNodeUFM
(NodeUFMData j' p')
t1'
projects / ghc-hetmet.git / commitdiff