| ... |
... |
@@ -2056,16 +2056,20 @@ is a join point, and what 'cont' is, in a value of type MaybeJoinCont |
|
2056
|
2056
|
of a SpecConstr-generated RULE for a join point.
|
|
2057
|
2057
|
-}
|
|
2058
|
2058
|
|
|
2059
|
|
--- SLD TODO horrible logic that must be removed
|
|
2060
|
|
-peelJoinResTy :: Int -> Type -> Type
|
|
2061
|
|
-peelJoinResTy 0 ty = ty
|
|
2062
|
|
-peelJoinResTy n ty
|
|
2063
|
|
- | Just (_bndr, inner_ty) <- splitForAllTyCoVar_maybe ty
|
|
2064
|
|
- = peelJoinResTy n inner_ty
|
|
2065
|
|
- | Just (_, _mult, _arg, res_ty) <- splitFunTy_maybe ty
|
|
2066
|
|
- = peelJoinResTy (n-1) res_ty
|
|
2067
|
|
- | otherwise
|
|
2068
|
|
- = ty
|
|
|
2059
|
+joinResTy :: HasDebugCallStack => JoinArity -> Type -> Type
|
|
|
2060
|
+joinResTy n0 ty0 = go n0 ty0
|
|
|
2061
|
+ where
|
|
|
2062
|
+ go 0 ty = ty
|
|
|
2063
|
+ go n ty
|
|
|
2064
|
+ | Just (_bndr, res_ty) <- splitPiTy_maybe ty
|
|
|
2065
|
+ = go (n-1) res_ty
|
|
|
2066
|
+ | otherwise
|
|
|
2067
|
+ = pprPanic "joinResTy" $
|
|
|
2068
|
+ vcat [ text "join arity:" <+> ppr n0
|
|
|
2069
|
+ , text "join ty:" <+> ppr ty0
|
|
|
2070
|
+ , text "n:" <+> ppr n
|
|
|
2071
|
+ , text "ty:" <+> ppr ty
|
|
|
2072
|
+ ]
|
|
2069
|
2073
|
|
|
2070
|
2074
|
simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr
|
|
2071
|
2075
|
-> InExpr -> SimplCont
|
| ... |
... |
@@ -2078,12 +2082,18 @@ simplNonRecJoinPoint env bndr rhs body cont |
|
2078
|
2082
|
; let (mult, res_ty)
|
|
2079
|
2083
|
-- SLD TODO
|
|
2080
|
2084
|
| Just QuasiJoinPoint <- joinId_maybe bndr
|
|
2081
|
|
- = (idMult bndr, peelJoinResTy (idJoinArity bndr) $ substTy env (idType bndr))
|
|
|
2085
|
+ = (idMult bndr, joinResTy (idJoinArity bndr) $ substTy env (idType bndr))
|
|
2082
|
2086
|
| otherwise
|
|
2083
|
2087
|
= (contHoleScaling cont, contResultType cont)
|
|
|
2088
|
+
|
|
|
2089
|
+ -- SLD TODO explain, refactor
|
|
|
2090
|
+ ; let bind_cont
|
|
|
2091
|
+ | do_case_case = cont
|
|
|
2092
|
+ | otherwise = mkBoringStop res_ty
|
|
|
2093
|
+
|
|
2084
|
2094
|
; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty
|
|
2085
|
|
- ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont)
|
|
2086
|
|
- ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env)
|
|
|
2095
|
+ ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive bind_cont)
|
|
|
2096
|
+ ; (floats1, env3) <- simplJoinBind NonRecursive bind_cont (bndr,env) (bndr2,env2) (rhs,env)
|
|
2087
|
2097
|
; (floats2, body') <- simplExprF env3 body cont
|
|
2088
|
2098
|
; return (floats1 `addFloats` floats2, body') }
|
|
2089
|
2099
|
where
|
| ... |
... |
@@ -2096,23 +2106,30 @@ simplNonRecJoinPoint env bndr rhs body cont |
|
2096
|
2106
|
simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]
|
|
2097
|
2107
|
-> InExpr -> SimplCont
|
|
2098
|
2108
|
-> SimplM (SimplFloats, OutExpr)
|
|
2099
|
|
-simplRecJoinPoint env pairs body cont
|
|
2100
|
|
- = wrapJoinCont do_case_case env cont $ \ env cont ->
|
|
|
2109
|
+simplRecJoinPoint env pairs body cont0
|
|
|
2110
|
+ = wrapJoinCont do_case_case env cont0 $ \ env cont ->
|
|
2101
|
2111
|
do { let bndrs = map fst pairs
|
|
2102
|
2112
|
(mult, res_ty)
|
|
2103
|
2113
|
-- SLD TODO
|
|
2104
|
|
- | [b] <- bndrs
|
|
|
2114
|
+ | b:_ <- bndrs
|
|
2105
|
2115
|
, Just QuasiJoinPoint <- joinId_maybe b
|
|
2106
|
|
- = (idMult b, peelJoinResTy (idJoinArity b) $ substTy env (idType b))
|
|
|
2116
|
+ = (idMult b, joinResTy (idJoinArity b) $ substTy env (idType b))
|
|
2107
|
2117
|
| otherwise
|
|
2108
|
2118
|
= (contHoleScaling cont, contResultType cont)
|
|
2109
|
2119
|
; env1 <- simplRecJoinBndrs env bndrs mult res_ty
|
|
2110
|
2120
|
-- NB: bndrs' don't have unfoldings or rules
|
|
2111
|
2121
|
-- We add them as we go down
|
|
2112
|
|
- ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs
|
|
|
2122
|
+
|
|
|
2123
|
+ -- SLD TODO explain, refactor
|
|
|
2124
|
+ ; let bind_cont
|
|
|
2125
|
+ | do_case_case = cont
|
|
|
2126
|
+ | otherwise = mkBoringStop res_ty
|
|
|
2127
|
+
|
|
|
2128
|
+ ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive bind_cont) pairs
|
|
2113
|
2129
|
; (floats2, body') <- simplExprF env2 body cont
|
|
2114
|
2130
|
; return (floats1 `addFloats` floats2, body') }
|
|
2115
|
2131
|
where
|
|
|
2132
|
+
|
|
2116
|
2133
|
do_case_case =
|
|
2117
|
2134
|
if all ((== Just TrueJoinPoint) . joinId_maybe . fst) pairs
|
|
2118
|
2135
|
then seCaseCase env
|