2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 %************************************************************************
6 \section[SATMonad]{The Static Argument Transformation pass Monad}
8 %************************************************************************
11 #include "HsVersions.h"
13 module StgSATMonad ( getArgLists, saTransform ) where
19 getArgLists = panic "StgSATMonad.getArgLists"
20 saTransform = panic "StgSATMonad.saTransform"
23 %************************************************************************
25 \subsection{Utility Functions}
27 %************************************************************************
30 {- LATER: to end of file:
32 newSATNames :: [Id] -> SatM [Id]
33 newSATNames [] = returnSAT []
34 newSATNames (id:ids) = newSATName id (idType id) `thenSAT` \ id' ->
35 newSATNames ids `thenSAT` \ ids' ->
38 getArgLists :: StgRhs -> ([Arg Type],[Arg Id])
39 getArgLists (StgRhsCon _ _ _)
41 getArgLists (StgRhsClosure _ _ _ _ args _)
42 = ([], [Static v | v <- args])
47 saTransform :: Id -> StgRhs -> SatM StgBinding
48 saTransform binder rhs
49 = getSATInfo binder `thenSAT` \ r ->
51 Just (_,args) | any isStatic args
52 -- [Andre] test: do it only if we have more than one static argument.
53 --Just (_,args) | length (filter isStatic args) > 1
54 -> newSATName binder (new_ty args) `thenSAT` \ binder' ->
55 let non_static_args = get_nsa args (snd (getArgLists rhs))
57 newSATNames non_static_args `thenSAT` \ non_static_args' ->
58 mkNewRhs binder binder' args rhs non_static_args' non_static_args
59 `thenSAT` \ new_rhs ->
60 trace ("SAT(STG) "++ show (length (filter isStatic args))) (
61 returnSAT (StgNonRec binder new_rhs)
63 _ -> returnSAT (StgRec [(binder, rhs)])
66 get_nsa :: [Arg a] -> [Arg a] -> [a]
69 get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as
70 get_nsa (_:args) (_:as) = get_nsa args as
72 mkNewRhs binder binder' args rhs@(StgRhsClosure cc bi fvs upd rhsargs body) non_static_args' non_static_args
74 local_body = StgApp (StgVarArg binder')
75 [StgVarArg a | a <- non_static_args] emptyUniqSet
77 rec_body = StgRhsClosure cc bi fvs upd non_static_args'
78 (doStgSubst binder args subst_env body)
81 ((binder,binder'):zip non_static_args non_static_args')
84 StgRhsClosure cc bi fvs upd rhsargs
85 (StgLet (StgRec [(binder',rec_body)]) {-in-} local_body)
89 = instantiateTy [] (mkSigmaTy [] dict_tys' tau_ty')
91 -- get type info for the local function:
92 (tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder
93 (reg_arg_tys, res_type) = splitTyArgs tau_ty
95 -- now, we drop the ones that are
96 -- static, that is, the ones we will not pass to the local function
98 dict_tys' = dropStatics (take l args) dict_tys
99 reg_arg_tys' = dropStatics (drop l args) reg_arg_tys
100 tau_ty' = glueTyArgs reg_arg_tys' res_type
103 NOTE: This does not keep live variable/free variable information!!
106 doStgSubst binder orig_args subst_env body
109 substExpr (StgCon con args lvs)
110 = StgCon con (map substAtom args) emptyUniqSet
111 substExpr (StgPrim op args lvs)
112 = StgPrim op (map substAtom args) emptyUniqSet
113 substExpr expr@(StgApp (StgLitArg _) [] _)
115 substExpr (StgApp atom@(StgVarArg v) args lvs)
117 = StgApp (StgVarArg (lookupNoFailIdEnv subst_env v))
118 (remove_static_args orig_args args) emptyUniqSet
120 = StgApp (substAtom atom) (map substAtom args) lvs
121 substExpr (StgCase scrut lv1 lv2 uniq alts)
122 = StgCase (substExpr scrut) emptyUniqSet emptyUniqSet uniq (subst_alts alts)
124 subst_alts (StgAlgAlts ty alg_alts deflt)
125 = StgAlgAlts ty (map subst_alg_alt alg_alts) (subst_deflt deflt)
126 subst_alts (StgPrimAlts ty prim_alts deflt)
127 = StgPrimAlts ty (map subst_prim_alt prim_alts) (subst_deflt deflt)
128 subst_alg_alt (con, args, use_mask, rhs)
129 = (con, args, use_mask, substExpr rhs)
130 subst_prim_alt (lit, rhs)
131 = (lit, substExpr rhs)
132 subst_deflt StgNoDefault
134 subst_deflt (StgBindDefault var used rhs)
135 = StgBindDefault var used (substExpr rhs)
136 substExpr (StgLetNoEscape fv1 fv2 b body)
137 = StgLetNoEscape emptyUniqSet emptyUniqSet (substBinding b) (substExpr body)
138 substExpr (StgLet b body)
139 = StgLet (substBinding b) (substExpr body)
140 substExpr (StgSCC ty cc expr)
141 = StgSCC ty cc (substExpr expr)
142 substRhs (StgRhsCon cc v args)
143 = StgRhsCon cc v (map substAtom args)
144 substRhs (StgRhsClosure cc bi fvs upd args body)
145 = StgRhsClosure cc bi [] upd args (substExpr body)
147 substBinding (StgNonRec binder rhs)
148 = StgNonRec binder (substRhs rhs)
149 substBinding (StgRec pairs)
150 = StgRec (zip binders (map substRhs rhss))
152 (binders,rhss) = unzip pairs
154 substAtom atom@(StgLitArg lit) = atom
155 substAtom atom@(StgVarArg v)
156 = case lookupIdEnv subst_env v of
157 Just v' -> StgVarArg v'
160 remove_static_args _ []
162 remove_static_args (Static _:origs) (_:as)
163 = remove_static_args origs as
164 remove_static_args (NotStatic:origs) (a:as)
165 = substAtom a:remove_static_args origs as