Comments and laout only

1 files changed, 103 insertions, 49 deletions

diff --git a/compiler/simplStg/UnariseStg.lhs b/compiler/simplStg/UnariseStg.lhs
index ac439ebfd3..b1717ad120 100644
--- a/compiler/simplStg/UnariseStg.lhs
+++ b/compiler/simplStg/UnariseStg.lhs
@@ -67,56 +67,102 @@ unarise us binds = zipWith (\us -> unariseBinding us init_env) (listSplitUniqSup
 unariseBinding :: UniqSupply -> UnariseEnv -> StgBinding -> StgBinding
 unariseBinding us rho bind = case bind of
   StgNonRec x rhs -> StgNonRec x (unariseRhs us rho rhs)
-  StgRec xrhss    -> StgRec $ zipWith (\us (x, rhs) -> (x, unariseRhs us rho rhs)) (listSplitUniqSupply us) xrhss
+  StgRec xrhss    -> StgRec $ zipWith (\us (x, rhs) -> (x, unariseRhs us rho rhs)) 
+                                      (listSplitUniqSupply us) xrhss
 
 unariseRhs :: UniqSupply -> UnariseEnv -> StgRhs -> StgRhs
 unariseRhs us rho rhs = case rhs of
   StgRhsClosure ccs b_info fvs update_flag srt args expr
-    -> StgRhsClosure ccs b_info (unariseIds rho fvs) update_flag (unariseSRT rho srt) args' (unariseExpr us' rho' expr)
+    -> StgRhsClosure ccs b_info (unariseIds rho fvs) update_flag 
+                     (unariseSRT rho srt) args' (unariseExpr us' rho' expr)
     where (us', rho', args') = unariseIdBinders us rho args
   StgRhsCon ccs con args
     -> StgRhsCon ccs con (unariseArgs rho args)
 
+------------------------
 unariseExpr :: UniqSupply -> UnariseEnv -> StgExpr -> StgExpr
-unariseExpr us rho e = case e of
-  -- Particularly important where (##) is concerned (Note [The nullary (# #) constructor])
-  StgApp f [] | UbxTupleRep tys <- repType (idType f)
-    -> StgConApp (tupleCon UnboxedTuple (length tys)) (map StgVarArg (unariseId rho f))
-  StgApp f args -> StgApp f (unariseArgs rho args)
-  StgLit l -> StgLit l
-  StgConApp dc args | isUnboxedTupleCon dc -> StgConApp (tupleCon UnboxedTuple (length args')) args'
-                    | otherwise            -> StgConApp dc args'
-    where args' = unariseArgs rho args
-  StgOpApp op args ty -> StgOpApp op (unariseArgs rho args) ty
-  StgLam xs e -> StgLam xs' (unariseExpr us' rho' e)
-    where (us', rho', xs') = unariseIdBinders us rho xs
-  StgCase e case_lives alts_lives bndr srt alt_ty alts
-    -> StgCase (unariseExpr us1 rho e) (unariseLives rho case_lives) (unariseLives rho alts_lives) bndr (unariseSRT rho srt) alt_ty' alts'
-    where (us1, us2) = splitUniqSupply us
-          (alt_ty', alts') = case repType (idType bndr) of
-                    UbxTupleRep tys -> case alts of 
-                        (DEFAULT,  [], [],    e):_ -> (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys, uses, unariseExpr us2' rho' e)])
-                          where (us2', rho', ys) = unariseIdBinder us2 rho bndr
-                                uses = replicate (length ys) (not (isDeadBinder bndr))
-                                n = length tys
-                        [(DataAlt _, ys, uses, e)] -> (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys', uses', unariseExpr us2' rho'' e)])
-                          where (us2', rho', ys', uses') = unariseUsedIdBinders us2 rho ys uses
-                                rho'' = extendVarEnv rho' bndr ys'
-                                n = length ys'
-                        _                           -> panic "unariseExpr: strange unboxed tuple alts"
-                    UnaryRep _ -> (alt_ty, zipWith (\us alt -> unariseAlt us rho alt) (listSplitUniqSupply us2) alts)
-  StgLet bind e -> StgLet (unariseBinding us1 rho bind) (unariseExpr us2 rho e)
-    where (us1, us2) = splitUniqSupply us
-  StgLetNoEscape live_in_let live_in_bind bind e
-    -> StgLetNoEscape (unariseLives rho live_in_let) (unariseLives rho live_in_bind) (unariseBinding us1 rho bind) (unariseExpr us2 rho e)
-    where (us1, us2) = splitUniqSupply us
-  StgSCC cc bump_entry push_cc e -> StgSCC cc bump_entry push_cc (unariseExpr us rho e)
-  StgTick mod tick_n e -> StgTick mod tick_n (unariseExpr us rho e)
-
+unariseExpr _ rho (StgApp f args)
+  | null args
+  , UbxTupleRep tys <- repType (idType f)
+  =  -- Particularly important where (##) is concerned 
+     -- See Note [Nullary unboxed tuple]
+    StgConApp (tupleCon UnboxedTuple (length tys)) 
+              (map StgVarArg (unariseId rho f))
+
+  | otherwise
+  = StgApp f (unariseArgs rho args)
+
+unariseExpr _ _ (StgLit l) 
+  = StgLit l
+
+unariseExpr _ rho (StgConApp dc args)
+  | isUnboxedTupleCon dc = StgConApp (tupleCon UnboxedTuple (length args')) args'
+  | otherwise            = StgConApp dc args'
+  where 
+    args' = unariseArgs rho args
+
+unariseExpr _ rho (StgOpApp op args ty)
+  = StgOpApp op (unariseArgs rho args) ty
+
+unariseExpr us rho (StgLam xs e)
+  = StgLam xs' (unariseExpr us' rho' e)
+  where 
+    (us', rho', xs') = unariseIdBinders us rho xs
+
+unariseExpr us rho (StgCase e case_lives alts_lives bndr srt alt_ty alts)
+  = StgCase (unariseExpr us1 rho e) (unariseLives rho case_lives) 
+            (unariseLives rho alts_lives) bndr (unariseSRT rho srt) 
+            alt_ty' alts'
+ where 
+    (us1, us2) = splitUniqSupply us
+    (alt_ty', alts') = unariseAlts us2 rho alt_ty bndr (repType (idType bndr)) alts
+
+unariseExpr us rho (StgLet bind e)
+  = StgLet (unariseBinding us1 rho bind) (unariseExpr us2 rho e)
+  where 
+    (us1, us2) = splitUniqSupply us
+
+unariseExpr us rho (StgLetNoEscape live_in_let live_in_bind bind e)
+  = StgLetNoEscape (unariseLives rho live_in_let) (unariseLives rho live_in_bind) 
+                   (unariseBinding us1 rho bind) (unariseExpr us2 rho e)
+  where 
+    (us1, us2) = splitUniqSupply us
+
+unariseExpr us rho (StgSCC cc bump_entry push_cc e)
+  = StgSCC cc bump_entry push_cc (unariseExpr us rho e)
+unariseExpr us rho (StgTick mod tick_n e)
+  = StgTick mod tick_n (unariseExpr us rho e)
+
+------------------------
+unariseAlts :: UniqSupply -> UnariseEnv -> AltType -> Id -> RepType -> [StgAlt] -> (AltType, [StgAlt])
+unariseAlts us rho alt_ty _ (UnaryRep _) alts 
+  = (alt_ty, zipWith (\us alt -> unariseAlt us rho alt) (listSplitUniqSupply us) alts)
+
+unariseAlts us rho _ bndr (UbxTupleRep tys) ((DEFAULT, [], [], e) : _)
+  = (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys, uses, unariseExpr us2' rho' e)])
+  where 
+    (us2', rho', ys) = unariseIdBinder us rho bndr
+    uses = replicate (length ys) (not (isDeadBinder bndr))
+    n = length tys
+
+unariseAlts us rho _ bndr (UbxTupleRep _) [(DataAlt _, ys, uses, e)] 
+  = (UbxTupAlt n, [(DataAlt (tupleCon UnboxedTuple n), ys', uses', unariseExpr us2' rho'' e)])
+  where 
+    (us2', rho', ys', uses') = unariseUsedIdBinders us rho ys uses
+    rho'' = extendVarEnv rho' bndr ys'
+    n = length ys'
+
+unariseAlts _ _ _ _ (UbxTupleRep _) alts
+  = pprPanic "unariseExpr: strange unboxed tuple alts" (ppr alts)
+
+--------------------------
 unariseAlt :: UniqSupply -> UnariseEnv -> StgAlt -> StgAlt
-unariseAlt us rho (con, xs, uses, e) = (con, xs', uses', unariseExpr us' rho' e)
-  where (us', rho', xs', uses') = unariseUsedIdBinders us rho xs uses
+unariseAlt us rho (con, xs, uses, e) 
+  = (con, xs', uses', unariseExpr us' rho' e)
+  where 
+    (us', rho', xs', uses') = unariseUsedIdBinders us rho xs uses
 
+------------------------
 unariseSRT :: UnariseEnv -> SRT -> SRT
 unariseSRT _   NoSRT            = NoSRT
 unariseSRT rho (SRTEntries ids) = SRTEntries (concatMapVarSet (unariseId rho) ids)
@@ -136,16 +182,24 @@ unariseIds :: UnariseEnv -> [Id] -> [Id]
 unariseIds rho = concatMap (unariseId rho)
 
 unariseId :: UnariseEnv -> Id -> [Id]
-unariseId rho x = case lookupVarEnv rho x of
-  Just ys -> ASSERT2(case repType (idType x) of UbxTupleRep _ -> True; _ -> x == ubxTupleId0, text "unariseId: not unboxed tuple" <+> ppr x)
-             ys
-  Nothing -> ASSERT2(case repType (idType x) of UbxTupleRep _ -> False; _ -> True, text "unariseId: was unboxed tuple" <+> ppr x)
-             [x]
-
-unariseUsedIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> [Bool] -> (UniqSupply, UnariseEnv, [Id], [Bool])
-unariseUsedIdBinders us rho xs uses = case mapAccumL2 (\us rho (x, use) -> third3 (map (flip (,) use)) $ unariseIdBinder us rho x)
-                                                      us rho (zipEqual "unariseUsedIdBinders" xs uses) of
-                                        (us', rho', xs_usess) -> uncurry ((,,,) us' rho') (unzip (concat xs_usess))
+unariseId rho x 
+  | Just ys <- lookupVarEnv rho x
+  = ASSERT2( case repType (idType x) of UbxTupleRep _ -> True; _ -> x == ubxTupleId0 
+           , text "unariseId: not unboxed tuple" <+> ppr x )
+    ys
+
+  | otherwise
+  = ASSERT2( case repType (idType x) of UbxTupleRep _ -> False; _ -> True
+           , text "unariseId: was unboxed tuple" <+> ppr x )
+    [x]
+
+unariseUsedIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> [Bool] 
+                     -> (UniqSupply, UnariseEnv, [Id], [Bool])
+unariseUsedIdBinders us rho xs uses 
+  = case mapAccumL2 do_one us rho (zipEqual "unariseUsedIdBinders" xs uses) of
+      (us', rho', xs_usess) -> uncurry ((,,,) us' rho') (unzip (concat xs_usess))
+  where
+    do_one us rho (x, use) = third3 (map (flip (,) use)) (unariseIdBinder us rho x)
 
 unariseIdBinders :: UniqSupply -> UnariseEnv -> [Id] -> (UniqSupply, UnariseEnv, [Id])
 unariseIdBinders us rho xs = third3 concat $ mapAccumL2 unariseIdBinder us rho xs