Commit 06f69812 authored by U-EUROPE\dimitris's avatar U-EUROPE\dimitris

Merge branch 'master' of http://darcs.haskell.org/ghc

parents b30f8b65 dc257508
......@@ -181,7 +181,7 @@ duDefs dus = foldr get emptyNameSet dus
get (Just d1, _u1) d2 = d1 `unionNameSets` d2
allUses :: DefUses -> Uses
-- ^ Just like 'allUses', but 'Defs' are not eliminated from the 'Uses' returned
-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned
allUses dus = foldr get emptyNameSet dus
where
get (_d1, u1) u2 = u1 `unionNameSets` u2
......@@ -189,8 +189,7 @@ allUses dus = foldr get emptyNameSet dus
duUses :: DefUses -> Uses
-- ^ Collect all 'Uses', regardless of whether the group is itself used,
-- but remove 'Defs' on the way
duUses dus
= foldr get emptyNameSet dus
duUses dus = foldr get emptyNameSet dus
where
get (Nothing, rhs_uses) uses = rhs_uses `unionNameSets` uses
get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSets` uses)
......
......@@ -396,13 +396,15 @@ stmt :: { ExtCode }
| NAME '(' exprs0 ')' ';'
{% stmtMacro $1 $3 }
| 'switch' maybe_range expr '{' arms default '}'
{ doSwitch $2 $3 $5 $6 }
{ do as <- sequence $5; doSwitch $2 $3 as $6 }
| 'goto' NAME ';'
{ do l <- lookupLabel $2; stmtEC (CmmBranch l) }
| 'jump' expr maybe_actuals ';'
{ do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
| 'return' maybe_actuals ';'
{ do e <- sequence $2; stmtEC (CmmReturn e) }
| 'if' bool_expr 'goto' NAME
{ do l <- lookupLabel $4; cmmRawIf $2 l }
| 'if' bool_expr '{' body '}' else
{ cmmIfThenElse $2 $4 $6 }
......@@ -441,12 +443,16 @@ maybe_range :: { Maybe (Int,Int) }
: '[' INT '..' INT ']' { Just (fromIntegral $2, fromIntegral $4) }
| {- empty -} { Nothing }
arms :: { [([Int],ExtCode)] }
arms :: { [ExtFCode ([Int],Either BlockId ExtCode)] }
: {- empty -} { [] }
| arm arms { $1 : $2 }
arm :: { ([Int],ExtCode) }
: 'case' ints ':' '{' body '}' { ($2, $5) }
arm :: { ExtFCode ([Int],Either BlockId ExtCode) }
: 'case' ints ':' arm_body { do b <- $4; return ($2, b) }
arm_body :: { ExtFCode (Either BlockId ExtCode) }
: '{' body '}' { return (Right $2) }
| 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) }
ints :: { [Int] }
: INT { [ fromIntegral $1 ] }
......@@ -458,6 +464,8 @@ default :: { Maybe ExtCode }
-- 'default' branches
| {- empty -} { Nothing }
-- Note: OldCmm doesn't support a first class 'else' statement, though
-- CmmNode does.
else :: { ExtCode }
: {- empty -} { nopEC }
| 'else' '{' body '}' { $3 }
......@@ -952,6 +960,10 @@ cmmIfThenElse cond then_part else_part = do
-- fall through to join
code (labelC join_id)
cmmRawIf cond then_id = do
c <- cond
emitCond c then_id
-- 'emitCond cond true_id' emits code to test whether the cond is true,
-- branching to true_id if so, and falling through otherwise.
emitCond (BoolTest e) then_id = do
......@@ -991,7 +1003,7 @@ emitCond (e1 `BoolAnd` e2) then_id = do
-- optional range on the switch (eg. switch [0..7] {...}), or by
-- the minimum/maximum values from the branches.
doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)]
-> Maybe ExtCode -> ExtCode
doSwitch mb_range scrut arms deflt
= do
......@@ -1018,12 +1030,12 @@ doSwitch mb_range scrut arms deflt
-- ToDo: check for out of range and jump to default if necessary
stmtEC (CmmSwitch expr entries)
where
emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
emitArm (ints,code) = do
emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)]
emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
emitArm (ints,Right code) = do
blockid <- forkLabelledCodeEC code
return [ (i,blockid) | i <- ints ]
-- -----------------------------------------------------------------------------
-- Putting it all together
......
......@@ -15,14 +15,11 @@ Things to do:
This will fix the spill before stack check problem but only really as a side
effect. A 'real fix' probably requires making the spiller know about sp checks.
- There is some silly stuff happening with the Sp. We end up with code like:
Sp = Sp + 8; R1 = _vwf::I64; Sp = Sp -8
Seems to be perhaps caused by the issue above but also maybe a optimisation
pass needed?
EZY: I don't understand this comment. David Terei, can you clarify?
- Proc pass all arguments on the stack, adding more code and slowing down things
a lot. We either need to fix this or even better would be to get rid of
proc points.
- Proc points pass all arguments on the stack, adding more code and
slowing down things a lot. We either need to fix this or even better
would be to get rid of proc points.
- CmmInfo.cmmToRawCmm uses Old.Cmm, so it is called after converting Cmm.Cmm to
Old.Cmm. We should abstract it to work on both representations, it needs only to
......@@ -32,7 +29,7 @@ Things to do:
we could convert codeGen/StgCmm* clients to the Hoopl's semantics?
It's all deeply unsatisfactory.
- Improve preformance of Hoopl.
- Improve performance of Hoopl.
A nofib comparison of -fasm vs -fnewcodegen nofib compilation parameters
(using the same ghc-cmm branch +libraries compiled by the old codegenerator)
......@@ -50,6 +47,9 @@ Things to do:
So we generate a bit better code, but it takes us longer!
EZY: Also importantly, Hoopl uses dramatically more memory than the
old code generator.
- Are all blockToNodeList and blockOfNodeList really needed? Maybe we could
splice blocks instead?
......@@ -57,7 +57,7 @@ Things to do:
a block catenation function would be probably nicer than blockToNodeList
/ blockOfNodeList combo.
- loweSafeForeignCall seems too lowlevel. Just use Dataflow. After that
- lowerSafeForeignCall seems too lowlevel. Just use Dataflow. After that
delete splitEntrySeq from HooplUtils.
- manifestSP seems to touch a lot of the graph representation. It is
......@@ -76,6 +76,9 @@ Things to do:
calling convention, and the code for calling foreign calls is generated
- AsmCodeGen has a generic Cmm optimiser; move this into new pipeline
EZY (2011-04-16): The mini-inliner has been generalized and ported,
but the constant folding and other optimizations need to still be
ported.
- AsmCodeGen has post-native-cg branch eliminator (shortCutBranches);
we ultimately want to share this with the Cmm branch eliminator.
......@@ -113,7 +116,7 @@ Things to do:
- See "CAFs" below; we want to totally refactor the way SRTs are calculated
- Pull out Areas into its own module
Parameterise AreaMap
Parameterise AreaMap (note there are type synonyms in CmmStackLayout!)
Add ByteWidth = Int
type SubArea = (Area, ByteOff, ByteWidth)
ByteOff should not be defined in SMRep -- that is too high up the hierarchy
......@@ -293,8 +296,8 @@ cpsTop:
insert spills/reloads across
LastCalls, and
Branches to proc-points
Now sink those reloads:
- CmmSpillReload.insertLateReloads
Now sink those reloads (and other instructions):
- CmmSpillReload.rewriteAssignments
- CmmSpillReload.removeDeadAssignmentsAndReloads
* CmmStackLayout.stubSlotsOnDeath
......@@ -344,7 +347,7 @@ to J that way. This is an awkward choice. (We think that we currently
never pass variables to join points via arguments.)
Furthermore, there is *no way* to pass q to J in a register (other
than a paramter register).
than a parameter register).
What we want is to do register allocation across the whole caboodle.
Then we could drop all the code that deals with the above awkward
......
......@@ -3,15 +3,7 @@
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\begin{code}
{-# OPTIONS -fno-warn-incomplete-patterns #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
{-# LANGUAGE DeriveDataTypeable #-}
-- | Abstract syntax of global declarations.
......@@ -630,15 +622,15 @@ instance OutputableBndr name
(ppr new_or_data <+>
(if isJust typats then ptext (sLit "instance") else empty) <+>
pp_decl_head (unLoc context) ltycon tyvars typats <+>
ppr_sig mb_sig)
ppr_sigx mb_sig)
(pp_condecls condecls)
derivings
where
ppr_sig Nothing = empty
ppr_sig (Just kind) = dcolon <+> pprKind kind
ppr_sigx Nothing = empty
ppr_sigx (Just kind) = dcolon <+> pprKind kind
ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
tcdFDs = fds,
tcdFDs = fds,
tcdSigs = sigs, tcdMeths = methods, tcdATs = ats})
| null sigs && null ats -- No "where" part
= top_matter
......@@ -773,14 +765,14 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where
ppr = pprConDecl
pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
pprConDecl (ConDecl { con_name =con, con_explicit = expl, con_qvars = tvs
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = details
, con_res = ResTyH98, con_doc = doc })
= sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
= sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
where
ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
ppr_details con (RecCon fields) = ppr con <+> pprConDeclFields fields
ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
ppr_details (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
ppr_details (RecCon fields) = ppr con <+> pprConDeclFields fields
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = PrefixCon arg_tys
......@@ -802,7 +794,7 @@ pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyG
%************************************************************************
%* *
\subsection[InstDecl]{An instance declaration
\subsection[InstDecl]{An instance declaration}
%* *
%************************************************************************
......@@ -835,7 +827,7 @@ instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats
%************************************************************************
%* *
\subsection[DerivDecl]{A stand-alone instance deriving declaration
\subsection[DerivDecl]{A stand-alone instance deriving declaration}
%* *
%************************************************************************
......
......@@ -6,12 +6,6 @@
HsImpExp: Abstract syntax: imports, exports, interfaces
\begin{code}
{-# OPTIONS -fno-warn-incomplete-patterns #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
{-# LANGUAGE DeriveDataTypeable #-}
module HsImpExp where
......@@ -103,6 +97,7 @@ ieName (IEVar n) = n
ieName (IEThingAbs n) = n
ieName (IEThingWith n _) = n
ieName (IEThingAll n) = n
ieName _ = panic "ieName failed pattern match!"
ieNames :: IE a -> [a]
ieNames (IEVar n ) = [n]
......@@ -122,8 +117,8 @@ instance (Outputable name) => Outputable (IE name) where
ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"]
ppr (IEThingWith thing withs)
= ppr thing <> parens (fsep (punctuate comma (map pprHsVar withs)))
ppr (IEModuleContents mod)
= ptext (sLit "module") <+> ppr mod
ppr (IEModuleContents mod')
= ptext (sLit "module") <+> ppr mod'
ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">")
ppr (IEDoc doc) = ppr doc
ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">")
......
......@@ -900,8 +900,8 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
finsts_mod = mi_finsts iface
hash_env = mi_hash_fn iface
mod_hash = mi_mod_hash iface
export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
| otherwise = Nothing
export_hash | depend_on_exports = Just (mi_exp_hash iface)
| otherwise = Nothing
used_occs = lookupModuleEnv ent_map mod `orElse` []
......@@ -918,21 +918,21 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
Just r -> r
depend_on_exports mod =
case lookupModuleEnv direct_imports mod of
Just _ -> True
-- Even if we used 'import M ()', we have to register a
-- usage on the export list because we are sensitive to
-- changes in orphan instances/rules.
Nothing -> False
-- In GHC 6.8.x the above line read "True", and in
-- fact it recorded a dependency on *all* the
-- modules underneath in the dependency tree. This
-- happens to make orphans work right, but is too
-- expensive: it'll read too many interface files.
-- The 'isNothing maybe_iface' check above saved us
-- from generating many of these usages (at least in
-- one-shot mode), but that's even more bogus!
depend_on_exports = is_direct_import
{- True
Even if we used 'import M ()', we have to register a
usage on the export list because we are sensitive to
changes in orphan instances/rules.
False
In GHC 6.8.x we always returned true, and in
fact it recorded a dependency on *all* the
modules underneath in the dependency tree. This
happens to make orphans work right, but is too
expensive: it'll read too many interface files.
The 'isNothing maybe_iface' check above saved us
from generating many of these usages (at least in
one-shot mode), but that's even more bogus!
-}
\end{code}
\begin{code}
......
......@@ -16,7 +16,6 @@ module DriverMkDepend (
#include "HsVersions.h"
import qualified GHC
-- import GHC ( ModSummary(..), GhcMonad )
import GhcMonad
import HsSyn ( ImportDecl(..) )
import DynFlags
......@@ -35,7 +34,6 @@ import FastString
import Exception
import ErrUtils
-- import MonadUtils ( liftIO )
import System.Directory
import System.FilePath
......
......@@ -779,9 +779,9 @@ runPhase (Cpp sf) input_fn dflags0
src_opts <- io $ getOptionsFromFile dflags0 output_fn
(dflags2, unhandled_flags, warns)
<- io $ parseDynamicNoPackageFlags dflags0 src_opts
io $ checkProcessArgsResult unhandled_flags
unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns
-- the HsPp pass below will emit warnings
io $ checkProcessArgsResult unhandled_flags
setDynFlags dflags2
......@@ -814,8 +814,8 @@ runPhase (HsPp sf) input_fn dflags
(dflags1, unhandled_flags, warns)
<- io $ parseDynamicNoPackageFlags dflags src_opts
setDynFlags dflags1
io $ handleFlagWarnings dflags1 warns
io $ checkProcessArgsResult unhandled_flags
io $ handleFlagWarnings dflags1 warns
return (Hsc sf, output_fn)
......
......@@ -1405,17 +1405,14 @@ preprocessFile hsc_env src_fn mb_phase Nothing
preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
= do
let dflags = hsc_dflags hsc_env
-- case we bypass the preprocessing stage?
let
local_opts = getOptions dflags buf src_fn
--
let local_opts = getOptions dflags buf src_fn
(dflags', leftovers, warns)
<- parseDynamicNoPackageFlags dflags local_opts
checkProcessArgsResult leftovers
handleFlagWarnings dflags' warns
let
needs_preprocessing
let needs_preprocessing
| Just (Unlit _) <- mb_phase = True
| Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
-- note: local_opts is only required if there's no Unlit phase
......
......@@ -1132,12 +1132,11 @@ hscTcExpr -- Typecheck an expression (but don't run it)
hscTcExpr hsc_env expr = runHsc hsc_env $ do
maybe_stmt <- hscParseStmt expr
case maybe_stmt of
Just (L _ (ExprStmt expr _ _)) ->
ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
_ ->
liftIO $ throwIO $ mkSrcErr $ unitBag $
mkPlainErrMsg noSrcSpan
(text "not an expression:" <+> quotes (text expr))
Just (L _ (ExprStmt expr _ _)) ->
ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
_ ->
liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg noSrcSpan
(text "not an expression:" <+> quotes (text expr))
-- | Find the kind of a type
hscKcType
......
......@@ -717,7 +717,7 @@ type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)]
-- | A ModGuts is carried through the compiler, accumulating stuff as it goes
-- There is only one ModGuts at any time, the one for the module
-- being compiled right now. Once it is compiled, a 'ModIface' and
-- 'ModDetails' are extracted and the ModGuts is dicarded.
-- 'ModDetails' are extracted and the ModGuts is discarded.
data ModGuts
= ModGuts {
mg_module :: !Module, -- ^ Module being compiled
......
......@@ -192,16 +192,12 @@ opt_IgnoreDotGhci = lookUp (fsLit "-ignore-dot-ghci")
-- debugging options
-- | Suppress all that is suppressable in core dumps.
-- Except for uniques, as some simplifier phases introduce new varibles that
-- have otherwise identical names.
opt_SuppressAll :: Bool
opt_SuppressAll
= lookUp (fsLit "-dsuppress-all")
-- | Suppress unique ids on variables.
opt_SuppressUniques :: Bool
opt_SuppressUniques
= lookUp (fsLit "-dsuppress-all")
|| lookUp (fsLit "-dsuppress-uniques")
-- | Suppress all coercions, them replacing with '...'
opt_SuppressCoercions :: Bool
opt_SuppressCoercions
......@@ -232,10 +228,16 @@ opt_SuppressTypeSignatures
= lookUp (fsLit "-dsuppress-all")
|| lookUp (fsLit "-dsuppress-type-signatures")
-- | Suppress unique ids on variables.
-- Except for uniques, as some simplifier phases introduce new variables that
-- have otherwise identical names.
opt_SuppressUniques :: Bool
opt_SuppressUniques
= lookUp (fsLit "-dsuppress-uniques")
-- | Display case expressions with a single alternative as strict let bindings
opt_PprCaseAsLet :: Bool
opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let")
opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let")
-- | Set the maximum width of the dumps
-- If GHC's command line options are bad then the options parser uses the
......
......@@ -1856,7 +1856,7 @@ pragState dynflags buf loc = (mkPState dynflags buf loc) {
mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
mkPState flags buf loc =
PState {
buffer = buf,
buffer = buf,
dflags = flags,
messages = emptyMessages,
last_loc = mkSrcSpan loc loc,
......@@ -1873,34 +1873,34 @@ mkPState flags buf loc =
alr_justClosedExplicitLetBlock = False
}
where
bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
.|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
.|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
.|. arrowsBit `setBitIf` xopt Opt_Arrows flags
.|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
.|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
.|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
.|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
.|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
.|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
.|. haddockBit `setBitIf` dopt Opt_Haddock flags
.|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
.|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
.|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
.|. recBit `setBitIf` xopt Opt_DoRec flags
.|. recBit `setBitIf` xopt Opt_Arrows flags
.|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
.|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
.|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
.|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
.|. arrowsBit `setBitIf` xopt Opt_Arrows flags
.|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
.|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
.|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
.|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
.|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
.|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
.|. haddockBit `setBitIf` dopt Opt_Haddock flags
.|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
.|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
.|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
.|. recBit `setBitIf` xopt Opt_DoRec flags
.|. recBit `setBitIf` xopt Opt_Arrows flags
.|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
.|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
.|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags
.|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags
.|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
.|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
.|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
.|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
.|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
| otherwise = 0
| otherwise = 0
addWarning :: DynFlag -> SrcSpan -> SDoc -> P ()
addWarning option srcspan warning
......
......@@ -54,7 +54,7 @@ Well, of course you'd need a lot of rules if you did it
like that, so we use a BuiltinRule instead, so that we
can match in any two literal values. So the rule is really
more like
(Lit 4) +# (Lit y) = Lit (x+#y)
(Lit x) +# (Lit y) = Lit (x+#y)
where the (+#) on the rhs is done at compile time
That is why these rules are built in here. Other rules
......
......@@ -1252,4 +1252,4 @@ add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
add_sig :: LSig a -> HsValBinds a -> HsValBinds a
add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
\end{code}
\ No newline at end of file
\end{code}
......@@ -370,13 +370,21 @@ getCoreToDo dflags
simpl_phase phase names iter
= CoreDoPasses
[ maybe_strictness_before phase
$ [ maybe_strictness_before phase
, CoreDoSimplify iter
(base_mode { sm_phase = Phase phase
, sm_names = names })
, maybe_rule_check (Phase phase)
]
, maybe_rule_check (Phase phase) ]
-- Vectorisation can introduce a fair few common sub expressions involving
-- DPH primitives. For example, see the Reverse test from dph-examples.
-- We need to eliminate these common sub expressions before their definitions
-- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings,
-- so we also run simpl_gently to inline them.
++ (if dopt Opt_Vectorise dflags && phase == 3
then [CoreCSE, simpl_gently]
else [])
vectorisation
= runWhen (dopt Opt_Vectorise dflags) $
......
......@@ -12,11 +12,11 @@ is restricted to what the outside world understands (read C), and this
module checks to see if a foreign declaration has got a legal type.
\begin{code}
module TcForeign
(
tcForeignImports
module TcForeign
(
tcForeignImports
, tcForeignExports
) where
) where
#include "HsVersions.h"
......@@ -43,18 +43,18 @@ import FastString
-- Defines a binding
isForeignImport :: LForeignDecl name -> Bool
isForeignImport (L _ (ForeignImport _ _ _)) = True
isForeignImport _ = False
isForeignImport _ = False
-- Exports a binding
isForeignExport :: LForeignDecl name -> Bool
isForeignExport (L _ (ForeignExport _ _ _)) = True
isForeignExport _ = False
isForeignExport _ = False
\end{code}
%************************************************************************
%* *
%* *
\subsection{Imports}
%* *
%* *
%************************************************************************
\begin{code}
......@@ -64,22 +64,22 @@ tcForeignImports decls
tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
= addErrCtxt (foreignDeclCtxt fo) $
do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
; let
-- Drop the foralls before inspecting the
-- structure of the foreign type.
(_, t_ty) = tcSplitForAllTys sig_ty
(arg_tys, res_ty) = tcSplitFunTys t_ty
id = mkLocalId nm sig_ty
-- Use a LocalId to obey the invariant that locally-defined
-- things are LocalIds. However, it does not need zonking,
-- (so TcHsSyn.zonkForeignExports ignores it).
; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
-- Can't use sig_ty here because sig_ty :: Type and
-- we need HsType Id hence the undefined
; return (id, ForeignImport (L loc id) undefined imp_decl') }
= addErrCtxt (foreignDeclCtxt fo) $
do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
; let
-- Drop the foralls before inspecting the
-- structure of the foreign type.
(_, t_ty) = tcSplitForAllTys sig_ty
(arg_tys, res_ty) = tcSplitFunTys t_ty
id = mkLocalId nm sig_ty
-- Use a LocalId to obey the invariant that locally-defined
-- things are LocalIds. However, it does not need zonking,
-- (so TcHsSyn.zonkForeignExports ignores it).
; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
-- Can't use sig_ty here because sig_ty :: Type and