- get :: CoreExpr
- -> SatM (CoreExpr, Maybe (Id, SATInfo))
-
- get (CoTyApp e ty)
- = get e `thenSAT` \ (e',result) ->
- returnSAT (
- CoTyApp e' ty,
- case result of
- Nothing -> Nothing
- Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv))
- )
-
- get (App e a)
- = get e `thenSAT` \ (e', result) ->
- satAtom a `thenSAT_`
- let si = case a of
- (VarArg v) -> Static v
- _ -> NotStatic
- in
- returnSAT (
- App e' a,
- case result of
- Just (v,(tv,lv)) -> Just (v,(tv,lv++[si]))
- Nothing -> Nothing
- )
-
- get var@(Var v)
- = returnSAT (var, Just (v,([],[])))
-
- get e
- = satExpr e `thenSAT` \ e2 ->
- returnSAT (e2, Nothing)
--}
+ should_transform args
+ = staticArgsLength > 1 -- THIS IS THE DECISION POINT
+ where staticArgsLength = length (filter isStatic args)
+
+ mkNewRhs binder binder' args rhs = let
+ non_static_args :: [Id]
+ non_static_args = get_nsa args rhs_val_binders
+ where
+ get_nsa :: [Staticness a] -> [a] -> [a]
+ get_nsa [] _ = []
+ get_nsa _ [] = []
+ get_nsa (NotStatic:args) (v:as) = v:get_nsa args as
+ get_nsa (_:args) (_:as) = get_nsa args as
+
+ -- To do the transformation, the game plan is to:
+ -- 1. Create a small nonrecursive RHS that takes the
+ -- original arguments to the function but discards
+ -- the ones that are static and makes a call to the
+ -- SATed version with the remainder. We intend that
+ -- this will be inlined later, removing the overhead
+ -- 2. Bind this nonrecursive RHS over the original body
+ -- WITH THE SAME UNIQUE as the original body so that
+ -- any recursive calls to the original now go via
+ -- the small wrapper
+ -- 3. Rebind the original function to a new one which contains
+ -- our SATed function and just makes a call to it:
+ -- we call the thing making this call the local body
+
+ local_body = mkApps (Var binder') [Var a | a <- non_static_args]
+
+ nonrec_rhs = mkOrigLam local_body
+
+ -- HACK! The following is a fake SysLocal binder with
+ -- *the same* unique as binder.
+ -- the reason for this is the following:
+ -- this binder *will* get inlined but if it happen to be
+ -- a top level binder it is never removed as dead code,
+ -- therefore we have to remove that information (of it being
+ -- top-level or exported somehow.)
+ -- A better fix is to use binder directly but with the TopLevel
+ -- tag (or Exported tag) modified.
+ fake_binder = mkSysLocal (fsLit "sat")
+ (getUnique binder)
+ (idType binder)
+ rec_body = mkLams non_static_args
+ (Let (NonRec fake_binder nonrec_rhs) {-in-} rhs_body)
+ in return (mkOrigLam (Let (Rec [(binder', rec_body)]) {-in-} local_body))
+ where
+ (rhs_binders, rhs_body) = collectBinders rhs
+ rhs_val_binders = filter isId rhs_binders
+
+ mkOrigLam = mkLams rhs_binders
+
+ mkSATLamTy tyargs args
+ = substTy (mk_inst_tyenv tyargs tv_tmpl)
+ (mkSigmaTy tv_tmpl' theta_tys' tau_ty')
+ where
+ -- get type info for the local function:
+ (tv_tmpl, theta_tys, tau_ty) = (tcSplitSigmaTy . idType) binder
+ (reg_arg_tys, res_type) = splitFunTys tau_ty
+
+ -- now, we drop the ones that are
+ -- static, that is, the ones we will not pass to the local function
+ tv_tmpl' = dropStatics tyargs tv_tmpl
+
+ -- Extract the args that correspond to the theta tys (e.g. dictionaries) and argument tys (normal values)
+ (args1, args2) = splitAtList theta_tys args
+ theta_tys' = dropStatics args1 theta_tys
+ reg_arg_tys' = dropStatics args2 reg_arg_tys
+
+ -- Piece the function type back together from our static-filtered components
+ tau_ty' = mkFunTys reg_arg_tys' res_type
+
+ mk_inst_tyenv :: [Staticness Type] -> [TyVar] -> TvSubst
+ mk_inst_tyenv [] _ = emptyTvSubst
+ mk_inst_tyenv (Static s:args) (t:ts) = extendTvSubst (mk_inst_tyenv args ts) t s
+ mk_inst_tyenv (_:args) (_:ts) = mk_inst_tyenv args ts
+ mk_inst_tyenv _ _ = panic "mk_inst_tyenv"
+
+dropStatics :: [Staticness a] -> [b] -> [b]
+dropStatics [] t = t
+dropStatics (Static _:args) (_:ts) = dropStatics args ts
+dropStatics (_:args) (t:ts) = t:dropStatics args ts
+dropStatics _ _ = panic "dropStatics"
+
+isStatic :: Staticness a -> Bool
+isStatic NotStatic = False
+isStatic _ = True