diff options
| -rw-r--r-- | compiler/simplStg/UnariseStg.lhs | 152 |
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 |