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"
14 getArgLists, saTransform
17 import Type ( mkSigmaTy, TyVarTemplate,
18 splitSigmaTy, splitTyArgs,
19 glueTyArgs, instantiateTy, TauType(..),
20 Class, ThetaType(..), SigmaType(..),
23 import Id ( mkSysLocal, idType, eqId )
24 import Maybes ( Maybe(..) )
26 import SATMonad ( SATEnv(..), SATInfo(..), Arg(..), updSAEnv, insSAEnv,
27 SatM(..), initSAT, thenSAT, thenSAT_,
28 emptyEnvSAT, returnSAT, mapSAT, isStatic, dropStatics,
29 getSATInfo, newSATName )
30 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
32 import UniqSet ( UniqSet(..), emptyUniqSet )
37 %************************************************************************
39 \subsection{Utility Functions}
41 %************************************************************************
44 newSATNames :: [Id] -> SatM [Id]
45 newSATNames [] = returnSAT []
46 newSATNames (id:ids) = newSATName id (idType id) `thenSAT` \ id' ->
47 newSATNames ids `thenSAT` \ ids' ->
50 getArgLists :: StgRhs -> ([Arg Type],[Arg Id])
51 getArgLists (StgRhsCon _ _ _)
53 getArgLists (StgRhsClosure _ _ _ _ args _)
54 = ([], [Static v | v <- args])
59 saTransform :: Id -> StgRhs -> SatM StgBinding
60 saTransform binder rhs
61 = getSATInfo binder `thenSAT` \ r ->
63 Just (_,args) | any isStatic args
64 -- [Andre] test: do it only if we have more than one static argument.
65 --Just (_,args) | length (filter isStatic args) > 1
66 -> newSATName binder (new_ty args) `thenSAT` \ binder' ->
67 let non_static_args = get_nsa args (snd (getArgLists rhs))
69 newSATNames non_static_args `thenSAT` \ non_static_args' ->
70 mkNewRhs binder binder' args rhs non_static_args' non_static_args
71 `thenSAT` \ new_rhs ->
72 trace ("SAT(STG) "++ show (length (filter isStatic args))) (
73 returnSAT (StgNonRec binder new_rhs)
75 _ -> returnSAT (StgRec [(binder, rhs)])
78 get_nsa :: [Arg a] -> [Arg a] -> [a]
81 get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as
82 get_nsa (_:args) (_:as) = get_nsa args as
84 mkNewRhs binder binder' args rhs@(StgRhsClosure cc bi fvs upd rhsargs body) non_static_args' non_static_args
86 local_body = StgApp (StgVarArg binder')
87 [StgVarArg a | a <- non_static_args] emptyUniqSet
89 rec_body = StgRhsClosure cc bi fvs upd non_static_args'
90 (doStgSubst binder args subst_env body)
93 ((binder,binder'):zip non_static_args non_static_args')
96 StgRhsClosure cc bi fvs upd rhsargs
97 (StgLet (StgRec [(binder',rec_body)]) {-in-} local_body)
101 = instantiateTy [] (mkSigmaTy [] dict_tys' tau_ty')
103 -- get type info for the local function:
104 (tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder
105 (reg_arg_tys, res_type) = splitTyArgs tau_ty
107 -- now, we drop the ones that are
108 -- static, that is, the ones we will not pass to the local function
110 dict_tys' = dropStatics (take l args) dict_tys
111 reg_arg_tys' = dropStatics (drop l args) reg_arg_tys
112 tau_ty' = glueTyArgs reg_arg_tys' res_type
115 NOTE: This does not keep live variable/free variable information!!
118 doStgSubst binder orig_args subst_env body
121 substExpr (StgCon con args lvs)
122 = StgCon con (map substAtom args) emptyUniqSet
123 substExpr (StgPrim op args lvs)
124 = StgPrim op (map substAtom args) emptyUniqSet
125 substExpr expr@(StgApp (StgLitArg _) [] _)
127 substExpr (StgApp atom@(StgVarArg v) args lvs)
129 = StgApp (StgVarArg (lookupNoFailIdEnv subst_env v))
130 (remove_static_args orig_args args) emptyUniqSet
132 = StgApp (substAtom atom) (map substAtom args) lvs
133 substExpr (StgCase scrut lv1 lv2 uniq alts)
134 = StgCase (substExpr scrut) emptyUniqSet emptyUniqSet uniq (subst_alts alts)
136 subst_alts (StgAlgAlts ty alg_alts deflt)
137 = StgAlgAlts ty (map subst_alg_alt alg_alts) (subst_deflt deflt)
138 subst_alts (StgPrimAlts ty prim_alts deflt)
139 = StgPrimAlts ty (map subst_prim_alt prim_alts) (subst_deflt deflt)
140 subst_alg_alt (con, args, use_mask, rhs)
141 = (con, args, use_mask, substExpr rhs)
142 subst_prim_alt (lit, rhs)
143 = (lit, substExpr rhs)
144 subst_deflt StgNoDefault
146 subst_deflt (StgBindDefault var used rhs)
147 = StgBindDefault var used (substExpr rhs)
148 substExpr (StgLetNoEscape fv1 fv2 b body)
149 = StgLetNoEscape emptyUniqSet emptyUniqSet (substBinding b) (substExpr body)
150 substExpr (StgLet b body)
151 = StgLet (substBinding b) (substExpr body)
152 substExpr (StgSCC ty cc expr)
153 = StgSCC ty cc (substExpr expr)
154 substRhs (StgRhsCon cc v args)
155 = StgRhsCon cc v (map substAtom args)
156 substRhs (StgRhsClosure cc bi fvs upd args body)
157 = StgRhsClosure cc bi [] upd args (substExpr body)
159 substBinding (StgNonRec binder rhs)
160 = StgNonRec binder (substRhs rhs)
161 substBinding (StgRec pairs)
162 = StgRec (zip binders (map substRhs rhss))
164 (binders,rhss) = unzip pairs
166 substAtom atom@(StgLitArg lit) = atom
167 substAtom atom@(StgVarArg v)
168 = case lookupIdEnv subst_env v of
169 Just v' -> StgVarArg v'
172 remove_static_args _ []
174 remove_static_args (Static _:origs) (_:as)
175 = remove_static_args origs as
176 remove_static_args (NotStatic:origs) (a:as)
177 = substAtom a:remove_static_args origs as