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,
16 Id, UniType, SplitUniqSupply, PlainStgExpr(..)
19 import AbsUniType ( mkTyVarTy, mkSigmaTy, TyVarTemplate,
20 extractTyVarsFromTy, splitType, splitTyArgs,
21 glueTyArgs, instantiateTy, TauType(..),
22 Class, ThetaType(..), SigmaType(..),
26 import Id ( mkSysLocal, getIdUniType, eqId )
27 import Maybes ( Maybe(..) )
29 import SATMonad ( SATEnv(..), SATInfo(..), Arg(..), updSAEnv, insSAEnv,
30 SatM(..), initSAT, thenSAT, thenSAT_,
31 emptyEnvSAT, returnSAT, mapSAT, isStatic, dropStatics,
32 getSATInfo, newSATName )
33 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
36 import UniqSet ( UniqSet(..), emptyUniqSet )
41 %************************************************************************
43 \subsection{Utility Functions}
45 %************************************************************************
48 newSATNames :: [Id] -> SatM [Id]
49 newSATNames [] = returnSAT []
50 newSATNames (id:ids) = newSATName id (getIdUniType id) `thenSAT` \ id' ->
51 newSATNames ids `thenSAT` \ ids' ->
54 getArgLists :: PlainStgRhs -> ([Arg UniType],[Arg Id])
55 getArgLists (StgRhsCon _ _ _)
57 getArgLists (StgRhsClosure _ _ _ _ args _)
58 = ([], [Static v | v <- args])
63 saTransform :: Id -> PlainStgRhs -> SatM PlainStgBinding
64 saTransform binder rhs
65 = getSATInfo binder `thenSAT` \ r ->
67 Just (_,args) | any isStatic args
68 -- [Andre] test: do it only if we have more than one static argument.
69 --Just (_,args) | length (filter isStatic args) > 1
70 -> newSATName binder (new_ty args) `thenSAT` \ binder' ->
71 let non_static_args = get_nsa args (snd (getArgLists rhs))
73 newSATNames non_static_args `thenSAT` \ non_static_args' ->
74 mkNewRhs binder binder' args rhs non_static_args' non_static_args
75 `thenSAT` \ new_rhs ->
76 trace ("SAT(STG) "++ show (length (filter isStatic args))) (
77 returnSAT (StgNonRec binder new_rhs)
79 _ -> returnSAT (StgRec [(binder, rhs)])
82 get_nsa :: [Arg a] -> [Arg a] -> [a]
85 get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as
86 get_nsa (_:args) (_:as) = get_nsa args as
88 mkNewRhs binder binder' args rhs@(StgRhsClosure cc bi fvs upd rhsargs body) non_static_args' non_static_args
90 local_body = StgApp (StgVarAtom binder')
91 [StgVarAtom a | a <- non_static_args] emptyUniqSet
93 rec_body = StgRhsClosure cc bi fvs upd non_static_args'
94 (doStgSubst binder args subst_env body)
97 ((binder,binder'):zip non_static_args non_static_args')
100 StgRhsClosure cc bi fvs upd rhsargs
101 (StgLet (StgRec [(binder',rec_body)]) {-in-} local_body)
105 = instantiateTy [] (mkSigmaTy [] dict_tys' tau_ty')
107 -- get type info for the local function:
108 (tv_tmpl, dict_tys, tau_ty) = (splitType . getIdUniType) binder
109 (reg_arg_tys, res_type) = splitTyArgs tau_ty
111 -- now, we drop the ones that are
112 -- static, that is, the ones we will not pass to the local function
114 dict_tys' = dropStatics (take l args) dict_tys
115 reg_arg_tys' = dropStatics (drop l args) reg_arg_tys
116 tau_ty' = glueTyArgs reg_arg_tys' res_type
119 NOTE: This does not keep live variable/free variable information!!
122 doStgSubst binder orig_args subst_env body
125 substExpr (StgConApp con args lvs)
126 = StgConApp con (map substAtom args) emptyUniqSet
127 substExpr (StgPrimApp op args lvs)
128 = StgPrimApp op (map substAtom args) emptyUniqSet
129 substExpr expr@(StgApp (StgLitAtom _) [] _)
131 substExpr (StgApp atom@(StgVarAtom v) args lvs)
133 = StgApp (StgVarAtom (lookupNoFailIdEnv subst_env v))
134 (remove_static_args orig_args args) emptyUniqSet
136 = StgApp (substAtom atom) (map substAtom args) lvs
137 substExpr (StgCase scrut lv1 lv2 uniq alts)
138 = StgCase (substExpr scrut) emptyUniqSet emptyUniqSet uniq (subst_alts alts)
140 subst_alts (StgAlgAlts ty alg_alts deflt)
141 = StgAlgAlts ty (map subst_alg_alt alg_alts) (subst_deflt deflt)
142 subst_alts (StgPrimAlts ty prim_alts deflt)
143 = StgPrimAlts ty (map subst_prim_alt prim_alts) (subst_deflt deflt)
144 subst_alg_alt (con, args, use_mask, rhs)
145 = (con, args, use_mask, substExpr rhs)
146 subst_prim_alt (lit, rhs)
147 = (lit, substExpr rhs)
148 subst_deflt StgNoDefault
150 subst_deflt (StgBindDefault var used rhs)
151 = StgBindDefault var used (substExpr rhs)
152 substExpr (StgLetNoEscape fv1 fv2 b body)
153 = StgLetNoEscape emptyUniqSet emptyUniqSet (substBinding b) (substExpr body)
154 substExpr (StgLet b body)
155 = StgLet (substBinding b) (substExpr body)
156 substExpr (StgSCC ty cc expr)
157 = StgSCC ty cc (substExpr expr)
158 substRhs (StgRhsCon cc v args)
159 = StgRhsCon cc v (map substAtom args)
160 substRhs (StgRhsClosure cc bi fvs upd args body)
161 = StgRhsClosure cc bi [] upd args (substExpr body)
163 substBinding (StgNonRec binder rhs)
164 = StgNonRec binder (substRhs rhs)
165 substBinding (StgRec pairs)
166 = StgRec (zip binders (map substRhs rhss))
168 (binders,rhss) = unzip pairs
170 substAtom atom@(StgLitAtom lit) = atom
171 substAtom atom@(StgVarAtom v)
172 = case lookupIdEnv subst_env v of
173 Just v' -> StgVarAtom v'
176 remove_static_args _ []
178 remove_static_args (Static _:origs) (_:as)
179 = remove_static_args origs as
180 remove_static_args (NotStatic:origs) (a:as)
181 = substAtom a:remove_static_args origs as