merged master into late-dmdlate-dmd

1 files changed, 44 insertions, 48 deletions

diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index d7edf8e193..24b12f7237 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -43,7 +43,6 @@ import Maybes
 import Util
 import FastString
 import Outputable
-import UniqSupply
 
 import Control.Monad (when,void)
 
@@ -70,8 +69,8 @@ cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit
 
 cgExpr (StgLet binds expr)             = do { cgBind binds;     cgExpr expr }
 cgExpr (StgLetNoEscape _ _ binds expr) =
-  do { us <- newUniqSupply
-     ; let join_id = mkBlockId (uniqFromSupply us)
+  do { u <- newUnique
+     ; let join_id = mkBlockId u
      ; cgLneBinds join_id binds
      ; r <- cgExpr expr
      ; emitLabel join_id
@@ -107,7 +106,7 @@ cgLneBinds join_id (StgNonRec bndr rhs)
                 -- See Note [Saving the current cost centre]
         ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs
         ; fcode
-        ; addBindC (cg_id info) info }
+        ; addBindC info }
 
 cgLneBinds join_id (StgRec pairs)
   = do  { local_cc <- saveCurrentCostCentre
@@ -142,9 +141,9 @@ cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body)
   = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
 cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
   = cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args)
-        -- For a constructor RHS we want to generate a single chunk of 
-        -- code which can be jumped to from many places, which will 
-        -- return the constructor. It's easy; just behave as if it 
+        -- For a constructor RHS we want to generate a single chunk of
+        -- code which can be jumped to from many places, which will
+        -- return the constructor. It's easy; just behave as if it
         -- was an StgRhsClosure with a ConApp inside!
 
 -------------------------
@@ -194,9 +193,9 @@ heapcheck will take their worst case into account.
 In favour of omitting !Q!, !R!:
 
  - *May* save a heap overflow test,
-   if ...P... allocates anything.  
+   if ...P... allocates anything.
 
- - We can use relative addressing from a single Hp to 
+ - We can use relative addressing from a single Hp to
    get at all the closures so allocated.
 
  - No need to save volatile vars etc across heap checks
@@ -204,7 +203,7 @@ In favour of omitting !Q!, !R!:
 
 Against omitting !Q!, !R!
 
-  - May put a heap-check into the inner loop.  Suppose 
+  - May put a heap-check into the inner loop.  Suppose
         the main loop is P -> R -> P -> R...
         Q is the loop exit, and only it does allocation.
     This only hurts us if P does no allocation.  If P allocates,
@@ -213,7 +212,7 @@ Against omitting !Q!, !R!
   - May do more allocation than reqd.  This sometimes bites us
     badly.  For example, nfib (ha!) allocates about 30\% more space if the
     worst-casing is done, because many many calls to nfib are leaf calls
-    which don't need to allocate anything. 
+    which don't need to allocate anything.
 
     We can un-allocate, but that costs an instruction
 
@@ -249,7 +248,7 @@ Hence: two basic plans for
 
         ...save current cost centre...
 
-        ...code for e, 
+        ...code for e,
            with sequel (SetLocals r)
 
         ...restore current cost centre...
@@ -314,13 +313,20 @@ cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts
 
 {-
 Note [case on bool]
-
+~~~~~~~~~~~~~~~~~~~
 This special case handles code like
 
   case a <# b of
     True ->
     False ->
 
+-->  case tagToEnum# (a <$# b) of
+        True -> .. ; False -> ...
+
+--> case (a <$# b) of r ->
+    case tagToEnum# r of
+        True -> .. ; False -> ...
+
 If we let the ordinary case code handle it, we'll get something like
 
  tmp1 = a < b
@@ -339,8 +345,12 @@ So we add a special case to generate
 
 and later optimisations will further improve this.
 
-We should really change all these primops to return Int# instead, that
-would make this special case go away.
+Now that #6135 has been resolved it should be possible to remove that
+special case. The idea behind this special case and pre-6135 implementation
+of Bool-returning primops was that tagToEnum# was added implicitly in the
+codegen and then optimized away. Now the call to tagToEnum# is explicit
+in the source code, which allows to optimize it away at the earlier stages
+of compilation (i.e. at the Core level).
 -}
 
 
@@ -499,7 +509,7 @@ cgAlts gc_plan bndr (PrimAlt _) alts
                 -- PrimAlts always have a DEFAULT case
                 -- and it always comes first
 
-              tagged_cmms' = [(lit,code) 
+              tagged_cmms' = [(lit,code)
                              | (LitAlt lit, code) <- tagged_cmms]
         ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt
         ; return AssignedDirectly }
@@ -619,34 +629,21 @@ cgConApp con stg_args
         ; emit =<< fcode_init
         ; emitReturn [idInfoToAmode idinfo] }
 
-
 cgIdApp :: Id -> [StgArg] -> FCode ReturnKind
 cgIdApp fun_id [] | isVoidId fun_id = emitReturn []
-cgIdApp fun_id args
-  = do  { fun_info <- getCgIdInfo fun_id
-        ; case maybeLetNoEscape fun_info of
-            Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args
-            Nothing -> cgTailCall (cg_id fun_info) fun_info args }
-            -- NB. use (cg_id fun_info) instead of fun_id, because the former
-            -- may be externalised for -split-objs.
-            -- See StgCmm.maybeExternaliseId.
-
-cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode ReturnKind
-cgLneJump blk_id lne_regs args  -- Join point; discard sequel
-  = do  { adjustHpBackwards -- always do this before a tail-call
-        ; cmm_args <- getNonVoidArgAmodes args
-        ; emitMultiAssign lne_regs cmm_args
-        ; emit (mkBranch blk_id)
-        ; return AssignedDirectly }
-    
-cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ReturnKind
-cgTailCall fun_id fun_info args = do
-    dflags <- getDynFlags
+cgIdApp fun_id args = do
+    dflags   <- getDynFlags
+    fun_info <- getCgIdInfo fun_id
+    let fun_arg     = StgVarArg fun_id
+        fun_name    = idName            fun_id
+        fun         = idInfoToAmode     fun_info
+        lf_info     = cg_lf        fun_info
+        node_points dflags = nodeMustPointToIt dflags lf_info
     case (getCallMethod dflags fun_name (idCafInfo fun_id) lf_info (length args)) of
 
             -- A value in WHNF, so we can just return it.
         ReturnIt -> emitReturn [fun]    -- ToDo: does ReturnIt guarantee tagged?
-    
+
         EnterIt -> ASSERT( null args )  -- Discarding arguments
                    emitEnter fun
 
@@ -654,7 +651,7 @@ cgTailCall fun_id fun_info args = do
                 { tickySlowCall lf_info args
                 ; emitComment $ mkFastString "slowCall"
                 ; slowCall fun args }
-    
+
         -- A direct function call (possibly with some left-over arguments)
         DirectEntry lbl arity -> do
                 { tickyDirectCall arity args
@@ -662,15 +659,14 @@ cgTailCall fun_id fun_info args = do
                      then directCall NativeNodeCall   lbl arity (fun_arg:args)
                      else directCall NativeDirectCall lbl arity args }
 
-        JumpToIt {} -> panic "cgTailCall"       -- ???
-
-  where
-    fun_arg     = StgVarArg fun_id
-    fun_name    = idName            fun_id
-    fun         = idInfoToAmode     fun_info
-    lf_info     = cgIdInfoLF        fun_info
-    node_points dflags = nodeMustPointToIt dflags lf_info
-
+        -- Let-no-escape call
+        JumpToIt -> let (LneLoc blk_id lne_regs) = cg_loc fun_info
+                    in do
+                       { adjustHpBackwards -- always do this before a tail-call
+                       ; cmm_args <- getNonVoidArgAmodes args
+                       ; emitMultiAssign lne_regs cmm_args
+                       ; emit (mkBranch blk_id)
+                       ; return AssignedDirectly }
 
 emitEnter :: CmmExpr -> FCode ReturnKind
 emitEnter fun = do