Commit f33327aa authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Comments and laout only

parent 84bb8541
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment