diff options
Diffstat (limited to 'compiler/codeGen/StgCmmExpr.hs')
| -rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 39 |
1 files changed, 21 insertions, 18 deletions
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 6e6ad7e9d7..22fcfaf412 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} ----------------------------------------------------------------------------- -- @@ -13,6 +12,8 @@ module StgCmmExpr ( cgExpr ) where #include "HsVersions.h" +import GhcPrelude hiding ((<*>)) + import {-# SOURCE #-} StgCmmBind ( cgBind ) import StgCmmMonad @@ -51,8 +52,6 @@ import Control.Monad (unless,void) import Control.Arrow (first) import Data.Function ( on ) -import Prelude hiding ((<*>)) - ------------------------------------------------------------------------ -- cgExpr: the main function ------------------------------------------------------------------------ @@ -61,7 +60,8 @@ cgExpr :: StgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args -{- seq# a s ==> a -} +-- seq# a s ==> a +-- See Note [seq# magic] in PrelRules cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = cgIdApp a [] @@ -409,7 +409,8 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts ; v_info <- getCgIdInfo v ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr))) (idInfoToAmode v_info) - ; bindArgToReg (NonVoid bndr) + -- Add bndr to the environment + ; _ <- bindArgToReg (NonVoid bndr) ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } where reps_compatible = ((==) `on` (primRepSlot . idPrimRep)) v bndr @@ -435,7 +436,8 @@ it would be better to invoke some kind of panic function here. cgCase scrut@(StgApp v []) _ (PrimAlt _) _ = do { dflags <- getDynFlags ; mb_cc <- maybeSaveCostCentre True - ; withSequel (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut) + ; _ <- withSequel + (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut) ; restoreCurrentCostCentre mb_cc ; emitComment $ mkFastString "should be unreachable code" ; l <- newBlockId @@ -446,13 +448,14 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ {- Note [Handle seq#] ~~~~~~~~~~~~~~~~~~~~~ -case seq# a s of v - (# s', a' #) -> e +See Note [seq# magic] in PrelRules. +The special case for seq# in cgCase does this: + case seq# a s of v + (# s', a' #) -> e ==> - -case a of v - (# s', a' #) -> e + case a of v + (# s', a' #) -> e (taking advantage of the fact that the return convention for (# State#, a #) is the same as the return convention for just 'a') @@ -460,6 +463,7 @@ is the same as the return convention for just 'a') cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts = -- Note [Handle seq#] + -- And see Note [seq# magic] in PrelRules -- Use the same return convention as vanilla 'a'. cgCase (StgApp a []) bndr alt_type alts @@ -616,13 +620,12 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts branches' = [(tag+1,branch) | (tag,branch) <- branches] emitSwitch tag_expr branches' mb_deflt 1 fam_sz - else -- No, get tag from info table - do dflags <- getDynFlags - let -- Note that ptr _always_ has tag 1 - -- when the family size is big enough - untagged_ptr = cmmRegOffB bndr_reg (-1) - tag_expr = getConstrTag dflags (untagged_ptr) - emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1) + else -- No, get tag from info table + let -- Note that ptr _always_ has tag 1 + -- when the family size is big enough + untagged_ptr = cmmRegOffB bndr_reg (-1) + tag_expr = getConstrTag dflags (untagged_ptr) + in emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1) ; return AssignedDirectly } |