import Type ( mkTyConApp )
import CoreSyn
import CoreFVs ( exprFreeVars )
-import CoreUtils ( mkIfThenElse, bindNonRec )
+import CoreUtils ( mkIfThenElse, bindNonRec, exprType )
import Id ( Id, idType )
import PrelInfo ( pAT_ERROR_ID )
\begin{code}
mkHsTupleExpr :: [TypecheckedHsExpr] -> TypecheckedHsExpr
mkHsTupleExpr [e] = e
-mkHsTupleExpr es = ExplicitTuple es Unboxed
+mkHsTupleExpr es = ExplicitTuple es Boxed
mkHsPairExpr :: TypecheckedHsExpr -> TypecheckedHsExpr -> TypecheckedHsExpr
mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2]
(exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)
`intersectVarSet` local_vars)
+-- A | ys |- c :: [t:ts] t'
+-- A, xs |- e :: t
+-- ------------------------
+-- A | xs |- c e :: [ts] t'
+--
+-- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c
+
+dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg)
+ = dsExpr arg `thenDs` \ core_arg ->
+ let
+ arg_ty = exprType core_arg
+ stack' = arg_ty:stack
+ in
+ dsfixCmd ids local_vars stack' res_ty cmd
+ `thenDs` \ (core_cmd, free_vars, env_ids') ->
+ mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
+ newSysLocalDs arg_ty `thenDs` \ arg_id ->
+ -- push the argument expression onto the stack
+ let
+ core_body = bindNonRec arg_id core_arg
+ (buildEnvStack env_ids' (arg_id:stack_ids))
+ in
+ -- match the environment and stack against the input
+ matchEnvStack env_ids stack_ids core_body
+ `thenDs` \ core_map ->
+ returnDs (do_map_arrow ids
+ (envStackType env_ids stack)
+ (envStackType env_ids' stack')
+ res_ty
+ core_map
+ core_cmd,
+ (exprFreeVars core_arg `intersectVarSet` local_vars)
+ `unionVarSet` free_vars)
+
-- A | ys |- c :: [ts] t'
-- -----------------------------------------------
-- A | xs |- \ p1 ... pk -> c :: [t1:...:tk:ts] t'
dsCmd ids local_vars env_ids stack res_ty (HsPar cmd)
= dsCmd ids local_vars env_ids stack res_ty cmd
+-- A, xs |- e :: Bool
+-- A | xs1 |- c1 :: [ts] t
+-- A | xs2 |- c2 :: [ts] t
+-- ----------------------------------------
+-- A | xs |- if e then c1 else c2 :: [ts] t
+--
+-- ---> arr (\ ((xs)*ts) ->
+-- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
+-- c1 ||| c2
+
+dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd _loc)
+ = dsExpr cond `thenDs` \ core_cond ->
+ dsfixCmd ids local_vars stack res_ty then_cmd
+ `thenDs` \ (core_then, fvs_then, then_ids) ->
+ dsfixCmd ids local_vars stack res_ty else_cmd
+ `thenDs` \ (core_else, fvs_else, else_ids) ->
+ mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
+ dsLookupTyCon eitherTyConName `thenDs` \ either_con ->
+ dsLookupDataCon leftDataConName `thenDs` \ left_con ->
+ dsLookupDataCon rightDataConName `thenDs` \ right_con ->
+ let
+ left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e]
+ right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e]
+
+ in_ty = envStackType env_ids stack
+ then_ty = envStackType then_ids stack
+ else_ty = envStackType else_ids stack
+ sum_ty = mkTyConApp either_con [then_ty, else_ty]
+ fvs_cond = exprFreeVars core_cond `intersectVarSet` local_vars
+ in
+ matchEnvStack env_ids stack_ids
+ (mkIfThenElse core_cond
+ (left_expr then_ty else_ty (buildEnvStack then_ids stack_ids))
+ (right_expr then_ty else_ty (buildEnvStack else_ids stack_ids)))
+ `thenDs` \ core_if ->
+ returnDs(do_map_arrow ids in_ty sum_ty res_ty
+ core_if
+ (do_choice ids then_ty else_ty res_ty core_then core_else),
+ fvs_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)
+\end{code}
+
+Case commands are treated in much the same way as if commands
+(see above) except that there are more alternatives. For example
+
+ case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
+
+is translated to
+
+ arr (\ ((xs)*ts) -> case e of
+ p1 -> (Left (Left (xs1)*ts))
+ p2 -> Left ((Right (xs2)*ts))
+ p3 -> Right ((xs3)*ts)) >>>
+ (c1 ||| c2) ||| c3
+
+The idea is to extract the commands from the case, build a balanced tree
+of choices, and replace the commands with expressions that build tagged
+tuples, obtaining a case expression that can be desugared normally.
+To build all this, we use quadruples decribing segments of the list of
+case bodies, containing the following fields:
+1. an IdSet containing the environment variables free in the case bodies
+2. a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
+ into the case replacing the commands
+3. a sum type that is the common type of these expressions, and also the
+ input type of the arrow
+4. a CoreExpr for an arrow built by combining the translated command
+ bodies with |||.
+
+\begin{code}
dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc)
= dsExpr exp `thenDs` \ core_exp ->
mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
map (right_expr in_ty1 in_ty2) builds2,
mkTyConApp either_con [in_ty1, in_ty2],
do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
- (fvs, leaves', sum_ty, core_choices) = foldb merge_branches branches
+ (fvs_alts, leaves', sum_ty, core_choices)
+ = foldb merge_branches branches
-- Replace the commands in the case with these tagged tuples,
-- yielding a TypecheckedHsExpr we can feed to dsExpr.
(_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
in_ty = envStackType env_ids stack
+ fvs_exp = exprFreeVars core_exp `intersectVarSet` local_vars
in
- dsExpr (HsCase exp matches' src_loc) `thenDs` \ core_matches ->
+ dsExpr (HsCase exp matches' src_loc) `thenDs` \ core_body ->
+ matchEnvStack env_ids stack_ids core_body
+ `thenDs` \ core_matches ->
returnDs(do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
- exprFreeVars core_exp `unionVarSet` fvs)
-
--- A, xs |- e :: Bool
--- A | xs1 |- c1 :: [ts] t
--- A | xs2 |- c2 :: [ts] t
--- ----------------------------------------
--- A | xs |- if e then c1 else c2 :: [ts] t
---
--- ---> arr (\ ((xs)*ts) ->
--- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
--- c1 ||| c2
-
-dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd _loc)
- = dsExpr cond `thenDs` \ core_cond ->
- dsfixCmd ids local_vars stack res_ty then_cmd
- `thenDs` \ (core_then, fvs_then, then_ids) ->
- dsfixCmd ids local_vars stack res_ty else_cmd
- `thenDs` \ (core_else, fvs_else, else_ids) ->
- mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
- dsLookupTyCon eitherTyConName `thenDs` \ either_con ->
- dsLookupDataCon leftDataConName `thenDs` \ left_con ->
- dsLookupDataCon rightDataConName `thenDs` \ right_con ->
- let
- left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e]
- right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e]
-
- in_ty = envStackType env_ids stack
- then_ty = envStackType then_ids stack
- else_ty = envStackType else_ids stack
- sum_ty = mkTyConApp either_con [then_ty, else_ty]
- in
- matchEnvStack env_ids stack_ids
- (mkIfThenElse core_cond
- (left_expr then_ty else_ty (buildEnvStack then_ids stack_ids))
- (right_expr then_ty else_ty (buildEnvStack else_ids stack_ids)))
- `thenDs` \ core_if ->
- returnDs(do_map_arrow ids in_ty sum_ty res_ty
- core_if
- (do_choice ids then_ty else_ty res_ty core_then core_else),
- exprFreeVars core_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)
+ fvs_exp `unionVarSet` fvs_alts)
-- A | ys |- c :: [ts] t
-- ----------------------------------
-- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
-- A | xs |- ci :: [tsi] ti
-- -----------------------------------
--- A | xs |- (|e|) c1 ... cn :: [ts] t ---> e [t_xs] c1 ... cn
+-- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn
dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args _)
= let
matchSimply exp ctxt pat match_code fail_expr
\end{code}
-\begin{code}
+List of leaf expressions, with set of variables bound in each
--- list of leaf expressions, with set of variables bound in each
+\begin{code}
leavesMatch :: TypecheckedMatch -> [(TypecheckedHsExpr, IdSet)]
leavesMatch (Match pats _ (GRHSs grhss binds _ty))
= let
[(expr, mkVarSet (collectStmtsBinders stmts) `unionVarSet` defined_vars) |
GRHS stmts _locn <- grhss,
let ResultStmt expr _ = last stmts]
+\end{code}
--- Replace the leaf commands in a match
+Replace the leaf commands in a match
+\begin{code}
replaceLeavesMatch
:: Type -- new result type
-> [TypecheckedHsExpr] -- replacement leaf expressions of that type
TypecheckedGRHS) -- updated GRHS
replaceLeavesGRHS (leaf:leaves) (GRHS stmts srcloc)
= (leaves, GRHS (init stmts ++ [ResultStmt leaf srcloc]) srcloc)
-
\end{code}
Balanced fold of a non-empty list.
projects / ghc-hetmet.git / blobdiff