diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs index 084ed657624b978694e5c14f1e6b4a0c0b7e52a6..a71569e487fd41905d29ae875644fbe16baeed62 100644 --- a/compiler/coreSyn/CoreFVs.hs +++ b/compiler/coreSyn/CoreFVs.hs @@ -14,6 +14,9 @@ module CoreFVs ( exprFreeVarsDSet, exprFreeVarsList, exprFreeIds, + exprFreeIdsDSet, + exprFreeIdsList, + exprsFreeIdsDSet, exprsFreeIdsList, exprsFreeVars, exprsFreeVarsList, @@ -122,6 +125,21 @@ exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids exprFreeIds = exprSomeFreeVars isLocalId -- | Find all locally-defined free Ids in an expression +-- returning a deterministic set. +exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids +exprFreeIdsDSet = exprSomeFreeVarsDSet isLocalId + +-- | Find all locally-defined free Ids in an expression +-- returning a deterministically ordered list. +exprFreeIdsList :: CoreExpr -> [Id] -- Find all locally-defined free Ids +exprFreeIdsList = exprSomeFreeVarsList isLocalId + +-- | Find all locally-defined free Ids in several expressions +-- returning a deterministic set. +exprsFreeIdsDSet :: [CoreExpr] -> DIdSet -- Find all locally-defined free Ids +exprsFreeIdsDSet = exprsSomeFreeVarsDSet isLocalId + +-- | Find all locally-defined free Ids in several expressions -- returning a deterministically ordered list. exprsFreeIdsList :: [CoreExpr] -> [Id] -- Find all locally-defined free Ids exprsFreeIdsList = exprsSomeFreeVarsList isLocalId @@ -162,6 +180,13 @@ exprSomeFreeVarsList :: InterestingVarFun -- ^ Says which 'Var's are interesting -> [Var] exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ expr_fvs e +-- | Finds free variables in an expression selected by a predicate +-- returning a deterministic set. +exprSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> CoreExpr + -> DVarSet +exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ expr_fvs e + -- | Finds free variables in several expressions selected by a predicate exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting -> [CoreExpr] @@ -177,6 +202,14 @@ exprsSomeFreeVarsList :: InterestingVarFun -- Says which 'Var's are interesting exprsSomeFreeVarsList fv_cand es = fvVarList $ filterFV fv_cand $ mapUnionFV expr_fvs es +-- | Finds free variables in several expressions selected by a predicate +-- returning a deterministic set. +exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> [CoreExpr] + -> DVarSet +exprsSomeFreeVarsDSet fv_cand e = + fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e + -- Comment about obselete code -- We used to gather the free variables the RULES at a variable occurrence -- with the following cryptic comment: diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index cdf839a47defb68bf3a6e3129b6fd5e412edb438..822708808ca665e72ff98167e54c31ca3707c46b 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -49,6 +49,7 @@ import SrcLoc import ListSetOps( assocDefault ) import Data.List import Util +import UniqDFM data DsCmdEnv = DsCmdEnv { arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr @@ -291,7 +292,7 @@ to an expression e such that -} dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id] - -> DsM (CoreExpr, IdSet) + -> DsM (CoreExpr, DIdSet) dsLCmd ids local_vars stk_ty res_ty cmd env_ids = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids @@ -304,7 +305,7 @@ dsCmd :: DsCmdEnv -- arrow combinators -- This is typically fed back, -- so don't pull on it too early -> DsM (CoreExpr, -- desugared expression - IdSet) -- subset of local vars that occur free + DIdSet) -- subset of local vars that occur free -- D |- fun :: a t1 t2 -- D, xs |- arg :: t1 @@ -329,7 +330,7 @@ dsCmd ids local_vars stack_ty res_ty res_ty core_make_arg core_arrow, - exprFreeIds core_arg `intersectVarSet` local_vars) + exprFreeIdsDSet core_arg `udfmIntersectUFM` local_vars) -- D, xs |- fun :: a t1 t2 -- D, xs |- arg :: t1 @@ -357,8 +358,8 @@ dsCmd ids local_vars stack_ty res_ty res_ty core_make_pair (do_app ids arg_ty res_ty), - (exprFreeIds core_arrow `unionVarSet` exprFreeIds core_arg) - `intersectVarSet` local_vars) + (exprsFreeIdsDSet [core_arrow, core_arg]) + `udfmIntersectUFM` local_vars) -- D; ys |-a cmd : (t,stk) --> t' -- D, xs |- exp :: t @@ -390,8 +391,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do res_ty core_map core_cmd, - free_vars `unionVarSet` - (exprFreeIds core_arg `intersectVarSet` local_vars)) + free_vars `unionDVarSet` + (exprFreeIdsDSet core_arg `udfmIntersectUFM` local_vars)) -- D; ys |-a cmd : stk t' -- ----------------------------------------------- @@ -428,7 +429,7 @@ dsCmd ids local_vars stack_ty res_ty -- match the old environment and stack against the input select_code <- matchEnvStack env_ids stack_id param_code return (do_premap ids in_ty in_ty' res_ty select_code core_body, - free_vars `minusVarSet` pat_vars) + free_vars `udfmMinusUFM` pat_vars) dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids = dsLCmd ids local_vars stack_ty res_ty cmd env_ids @@ -460,7 +461,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd) then_ty = envStackType then_ids stack_ty else_ty = envStackType else_ids stack_ty sum_ty = mkTyConApp either_con [then_ty, else_ty] - fvs_cond = exprFreeIds core_cond `intersectVarSet` local_vars + fvs_cond = exprFreeIdsDSet core_cond `udfmIntersectUFM` local_vars core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_id) core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id) @@ -474,7 +475,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd) return (do_premap 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) + fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else) {- Case commands are treated in much the same way as if commands @@ -556,7 +557,7 @@ dsCmd ids local_vars stack_ty res_ty core_matches <- matchEnvStack env_ids stack_id core_body return (do_premap ids in_ty sum_ty res_ty core_matches core_choices, - exprFreeIds core_body `intersectVarSet` local_vars) + exprFreeIdsDSet core_body `udfmIntersectUFM` local_vars) -- D; ys |-a cmd : stk --> t -- ---------------------------------- @@ -581,7 +582,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do res_ty core_map core_body, - exprFreeIds core_binds `intersectVarSet` local_vars) + exprFreeIdsDSet core_binds `udfmIntersectUFM` local_vars) -- D; xs |-a ss : t -- ---------------------------------- @@ -611,7 +612,7 @@ dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do core_op <- dsLExpr op (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args return (mkApps (App core_op (Type env_ty)) core_args, - unionVarSets fv_sets) + unionDVarSets fv_sets) dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids @@ -629,7 +630,7 @@ dsTrimCmdArg -> [Id] -- list of vars in the input to this command -> LHsCmdTop Id -- command argument to desugar -> DsM (CoreExpr, -- desugared expression - IdSet) -- subset of local vars that occur free + DIdSet) -- subset of local vars that occur free dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do (meth_binds, meth_ids) <- mkCmdEnv ids (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd @@ -652,7 +653,7 @@ dsfixCmd -> Type -- return type of the command -> LHsCmd Id -- command to desugar -> DsM (CoreExpr, -- desugared expression - IdSet, -- subset of local vars that occur free + DIdSet, -- subset of local vars that occur free [Id]) -- the same local vars as a list, fed back dsfixCmd ids local_vars stk_ty cmd_ty cmd = trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) @@ -661,16 +662,16 @@ dsfixCmd ids local_vars stk_ty cmd_ty cmd -- for use as the input tuple of the generated arrow. trimInput - :: ([Id] -> DsM (CoreExpr, IdSet)) + :: ([Id] -> DsM (CoreExpr, DIdSet)) -> DsM (CoreExpr, -- desugared expression - IdSet, -- subset of local vars that occur free + DIdSet, -- subset of local vars that occur free [Id]) -- same local vars as a list, fed back to -- the inner function to form the tuple of -- inputs to the arrow. trimInput build_arrow = fixDs (\ ~(_,_,env_ids) -> do (core_cmd, free_vars) <- build_arrow env_ids - return (core_cmd, free_vars, varSetElems free_vars)) + return (core_cmd, free_vars, dVarSetElems free_vars)) {- Translation of command judgements of the form @@ -686,7 +687,7 @@ dsCmdDo :: DsCmdEnv -- arrow combinators -- This is typically fed back, -- so don't pull on it too early -> DsM (CoreExpr, -- desugared expression - IdSet) -- subset of local vars that occur free + DIdSet) -- subset of local vars that occur free dsCmdDo _ _ _ [] _ = panic "dsCmdDo" @@ -729,7 +730,7 @@ translated to a composition of such arrows. -} dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id] - -> DsM (CoreExpr, IdSet) + -> DsM (CoreExpr, DIdSet) dsCmdLStmt ids local_vars out_ids cmd env_ids = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids @@ -742,7 +743,7 @@ dsCmdStmt -- This is typically fed back, -- so don't pull on it too early -> DsM (CoreExpr, -- desugared expression - IdSet) -- subset of local vars that occur free + DIdSet) -- subset of local vars that occur free -- D; xs1 |-a c : () --> t -- D; xs' |-a do { ss } : t' @@ -769,7 +770,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do do_compose ids before_c_ty after_c_ty out_ty (do_first ids in_ty1 c_ty out_ty core_cmd) $ do_arr ids after_c_ty out_ty snd_fn, - extendVarSetList fv_cmd out_ids) + extendDVarSetList fv_cmd out_ids) -- D; xs1 |-a c : () --> t -- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p) @@ -825,7 +826,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do do_compose ids before_c_ty after_c_ty out_ty (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $ do_arr ids after_c_ty out_ty proj_expr, - fv_cmd `unionVarSet` (mkVarSet out_ids `minusVarSet` pat_vars)) + fv_cmd `unionDVarSet` (mkDVarSet out_ids `udfmMinusUFM` pat_vars)) -- D; xs' |-a do { ss } : t -- -------------------------------------- @@ -842,7 +843,7 @@ dsCmdStmt ids local_vars out_ids (LetStmt (L _ binds)) env_ids = do (mkBigCoreVarTupTy env_ids) (mkBigCoreVarTupTy out_ids) core_map, - exprFreeIds core_binds `intersectVarSet` local_vars) + exprFreeIdsDSet core_binds `udfmIntersectUFM` local_vars) -- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ... -- D; xs' |-a do { ss' } : t @@ -866,7 +867,7 @@ dsCmdStmt ids local_vars out_ids let later_ids_set = mkVarSet later_ids env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids - env2_id_set = mkVarSet env2_ids + env2_id_set = mkDVarSet env2_ids env2_ty = mkBigCoreVarTupTy env2_ids -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) @@ -908,7 +909,7 @@ dsCmdStmt ids local_vars out_ids (do_arr ids post_pair_ty out_ty post_loop_fn)) - return (core_body, env1_id_set `unionVarSet` env2_id_set) + return (core_body, env1_id_set `unionDVarSet` env2_id_set) dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s) @@ -924,7 +925,7 @@ dsRecCmd -> [Id] -- list of vars fed back through the loop -> [HsExpr Id] -- expressions corresponding to rec_ids -> DsM (CoreExpr, -- desugared statement - IdSet, -- subset of local vars that occur free + DIdSet, -- subset of local vars that occur free [Id]) -- same local vars as a list dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do @@ -961,8 +962,8 @@ dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do rec_id <- newSysLocalDs rec_ty let - env1_id_set = fv_stmts `minusVarSet` rec_id_set - env1_ids = varSetElems env1_id_set + env1_id_set = fv_stmts `udfmMinusUFM` rec_id_set + env1_ids = dVarSetElems env1_id_set env1_ty = mkBigCoreVarTupTy env1_ids in_pair_ty = mkCorePairTy env1_ty rec_ty core_body = mkBigCoreTup (map selectVar env_ids) @@ -998,7 +999,7 @@ dsfixCmdStmts -> [Id] -- output vars of these statements -> [CmdLStmt Id] -- statements to desugar -> DsM (CoreExpr, -- desugared expression - IdSet, -- subset of local vars that occur free + DIdSet, -- subset of local vars that occur free [Id]) -- same local vars as a list dsfixCmdStmts ids local_vars out_ids stmts @@ -1011,7 +1012,7 @@ dsCmdStmts -> [CmdLStmt Id] -- statements to desugar -> [Id] -- list of vars in the input to these statements -> DsM (CoreExpr, -- desugared expression - IdSet) -- subset of local vars that occur free + DIdSet) -- subset of local vars that occur free dsCmdStmts ids local_vars out_ids [stmt] env_ids = dsCmdLStmt ids local_vars out_ids stmt env_ids diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs index 4bd97ef2eb8c58ac69575f0390970547e38b437c..91fb0ecbec1d4b85889281517bfe141fe29f4eb1 100644 --- a/compiler/utils/UniqDFM.hs +++ b/compiler/utils/UniqDFM.hs @@ -42,7 +42,7 @@ module UniqDFM ( filterUDFM, isNullUDFM, sizeUDFM, - intersectUDFM, + intersectUDFM, udfmIntersectUFM, intersectsUDFM, disjointUDFM, disjointUdfmUfm, minusUDFM, @@ -275,6 +275,11 @@ intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i -- M.intersection is left biased, that means the result will only have -- a subset of elements from the left set, so `i` is a good upper bound. +udfmIntersectUFM :: UniqDFM elt -> UniqFM elt -> UniqDFM elt +udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i + -- M.intersection is left biased, that means the result will only have + -- a subset of elements from the left set, so `i` is a good upper bound. + intersectsUDFM :: UniqDFM elt -> UniqDFM elt -> Bool intersectsUDFM x y = isNullUDFM (x `intersectUDFM` y) diff --git a/testsuite/driver/extra_files.py b/testsuite/driver/extra_files.py index d6e639dd28162c91efd74ab14de8974c3b4e354e..0a2bfe6686b87a367c8ba2e01a2bf69ea3a5305f 100644 --- a/testsuite/driver/extra_files.py +++ b/testsuite/driver/extra_files.py @@ -189,6 +189,7 @@ extra_src_files = { 'determ005': ['A.hs'], 'determ006': ['spec-inline-determ.hs'], 'determ010': ['A.hs'], + 'determ018': ['A.hs'], 'dodgy': ['DodgyA.hs'], 'driver011': ['A011.hs'], 'driver012': ['A012.hs'], diff --git a/testsuite/tests/determinism/determ018/A.hs b/testsuite/tests/determinism/determ018/A.hs new file mode 100644 index 0000000000000000000000000000000000000000..7017f5719c98eb4c6a767f7cacf6ef73db90de41 --- /dev/null +++ b/testsuite/tests/determinism/determ018/A.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE + Arrows + , TypeOperators + #-} +-- This is extracted from arrow-list package +-- The problem was that some internal tuples that Arrows desugaring +-- generates the components in different orders depending on the order +-- of Uniques. +module A +( + ifA +) +where + +import Control.Arrow +import Prelude hiding (id, (.)) + +class Arrow arr => ArrowList arr where + arrL :: (a -> [b]) -> a `arr` b + mapL :: ([b] -> [c]) -> (a `arr` b) -> (a `arr` c) + + +empty :: ArrowList arr => (a `arr` b) -> a `arr` Bool +empty = mapL (\xs -> [if null xs then True else False]) + + +ifA :: (ArrowList arr, ArrowChoice arr) + => (a `arr` c) -- ^ Arrow used as condition. + -> (a `arr` b) -- ^ Arrow to use when condition has results. + -> (a `arr` b) -- ^ Arrow to use when condition has no results. + -> a `arr` b +ifA c t e = proc i -> do x <- empty c -< i; if x then e -< i else t -< i diff --git a/testsuite/tests/determinism/determ018/Makefile b/testsuite/tests/determinism/determ018/Makefile new file mode 100644 index 0000000000000000000000000000000000000000..227c0903fa35a0751454b05130d511ddf120d194 --- /dev/null +++ b/testsuite/tests/determinism/determ018/Makefile @@ -0,0 +1,13 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +TEST_HC_OPTS_NO_RECOMP = $(filter-out -fforce-recomp,$(TEST_HC_OPTS)) + +determ018: + $(RM) A.hi A.o + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=0 -dunique-increment=1 -O A.hs + $(CP) A.hi A.normal.hi + $(RM) A.hi A.o + '$(TEST_HC)' $(TEST_HC_OPTS_NO_RECOMP) -dinitial-unique=16777215 -dunique-increment=-1 -O A.hs + diff A.hi A.normal.hi diff --git a/testsuite/tests/determinism/determ018/all.T b/testsuite/tests/determinism/determ018/all.T new file mode 100644 index 0000000000000000000000000000000000000000..96c35feb3a2ce34018c3c7ec88603eef3c353b93 --- /dev/null +++ b/testsuite/tests/determinism/determ018/all.T @@ -0,0 +1,4 @@ +test('determ018', + extra_clean(['A.o', 'A.hi', 'A.normal.hi']), + run_command, + ['$MAKE -s --no-print-directory determ018']) diff --git a/testsuite/tests/determinism/determ018/determ018.stdout b/testsuite/tests/determinism/determ018/determ018.stdout new file mode 100644 index 0000000000000000000000000000000000000000..60c2bc368d7fd2130884c82ab256c12c64a56950 --- /dev/null +++ b/testsuite/tests/determinism/determ018/determ018.stdout @@ -0,0 +1,2 @@ +[1 of 1] Compiling A ( A.hs, A.o ) +[1 of 1] Compiling A ( A.hs, A.o )