+-- There are two things going on in mkStgAlgAlts
+-- a) We pull out the type constructor for the case, from the data
+-- constructor, if there is one. See notes with the StgAlgAlts data type
+-- b) We force the type constructor to avoid space leaks
+
+mkStgAlgAlts ty alts deflt
+ = case alts of
+ -- Get the tycon from the data con
+ (dc, _, _, _):_ -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
+
+ -- Otherwise just do your best
+ [] -> case splitTyConApp_maybe (repType ty) of
+ Just (tc,_) | isAlgTyCon tc -> StgAlgAlts (Just tc) alts deflt
+ other -> StgAlgAlts Nothing alts deflt
+
+mkStgPrimAlts ty alts deflt
+ = case splitTyConApp ty of
+ (tc,_) -> StgPrimAlts tc alts deflt
+
+mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
+
+mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr
+ -- The type is the type of the entire application
+mkStgApp env fn args ty
+ = case idFlavour fn_alias of
+ DataConId dc
+ -> saturate fn_alias args ty $ \ args' ty' ->
+ returnUs (StgConApp dc args')
+
+ PrimOpId (CCallOp ccall)
+ -- Sigh...make a guaranteed unique name for a dynamic ccall
+ -- Done here, not earlier, because it's a code-gen thing
+ -> saturate fn_alias args ty $ \ args' ty' ->
+ getUniqueUs `thenUs` \ uniq ->
+ let ccall' = setCCallUnique ccall uniq in
+ returnUs (StgPrimApp (CCallOp ccall') args' ty')
+
+
+ PrimOpId op
+ -> saturate fn_alias args ty $ \ args' ty' ->
+ returnUs (StgPrimApp op args' ty')
+
+ other -> returnUs (StgApp fn_alias args)
+ -- Force the lookup
+ where
+ fn_alias = case (lookupVarEnv env fn) of -- In case it's been cloned
+ Nothing -> fn
+ Just fn' -> fn'
+
+saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr
+ -- The type should be the type of (id args)
+saturate fn args ty thing_inside
+ | excess_arity == 0 -- Saturated, so nothing to do
+ = thing_inside args ty
+
+ | otherwise -- An unsaturated constructor or primop; eta expand it
+ = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys,
+ ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
+ mapUs newStgVar extra_arg_tys `thenUs` \ arg_vars ->
+ thing_inside (args ++ map StgVarArg arg_vars) final_res_ty `thenUs` \ body ->
+ returnUs (StgLam ty arg_vars body)
+ where
+ fn_arity = idArity fn
+ excess_arity = fn_arity - length args
+ (arg_tys, res_ty) = splitRepFunTys ty
+ extra_arg_tys = take excess_arity arg_tys
+ final_res_ty = mkFunTys (drop excess_arity arg_tys) res_ty
+\end{code}
projects / ghc-hetmet.git / blobdiff