+{- Now redundant, I believe
+-- we overload the demandInfo field of an Id to indicate whether the Id is definitely
+-- evaluated or not (i.e. whether it is a case binder). This can be used to eliminate
+-- some redundant cases (c.f. dataToTag# above).
+
+newEvaldLocalId env id
+ = getUniqueUs `thenUs` \ uniq ->
+ let
+ id' = modifyIdInfo (`setDemandInfo` wwStrict) (setIdUnique id uniq)
+ new_env = extendVarEnv env id id'
+ in
+ returnUs (new_env, id')
+-}
+
+newEvaldLocalId env id = newLocalId NotTopLevel env id
+
+newLocalId TopLevel env id
+ -- Don't clone top-level binders. MkIface relies on their
+ -- uniques staying the same, so it can snaffle IdInfo off the
+ -- STG ids to put in interface files.
+ = let
+ name = idName id
+ ty = idType id
+ in
+ name `seq`
+ seqType ty `seq`
+ returnUs (env, mkVanillaId name ty)
+
+
+newLocalId NotTopLevel env id
+ = -- Local binder, give it a new unique Id.
+ getUniqueUs `thenUs` \ uniq ->
+ let
+ name = idName id
+ ty = idType id
+ new_id = mkVanillaId (setNameUnique name uniq) ty
+ new_env = extendVarEnv env id new_id
+ in
+ name `seq`
+ seqType ty `seq`
+ returnUs (new_env, new_id)
+
+newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
+newLocalIds top_lev env []
+ = returnUs (env, [])
+newLocalIds top_lev env (b:bs)
+ = newLocalId top_lev env b `thenUs` \ (env', b') ->
+ newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
+ returnUs (env'', b':bs')
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Building STG syn}
+%* *
+%************************************************************************
+
+\begin{code}
+mkStgAlgAlts ty alts deflt = seqType ty `seq` StgAlgAlts ty alts deflt
+mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt
+mkStgCon con args ty = seqType ty `seq` StgCon con args ty
+mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
+
+mkStgApp :: Id -> [StgArg] -> StgExpr
+mkStgApp fn args = fn `seq` StgApp fn args
+ -- Force the lookup
+\end{code}
+
+\begin{code}
+-- Stg doesn't have a lambda *expression*,
+deStgLam (StgLam ty bndrs body) = mkStgLamExpr ty bndrs body
+deStgLam expr = returnUs expr
+
+mkStgLamExpr ty bndrs body
+ = ASSERT( not (null bndrs) )
+ newStgVar ty `thenUs` \ fn ->
+ returnUs (StgLet (StgNonRec fn lam_closure) (mkStgApp fn []))
+ where
+ lam_closure = StgRhsClosure noCCS
+ stgArgOcc
+ noSRT
+ bOGUS_FVs
+ ReEntrant -- binders is non-empty
+ bndrs
+ body
+
+mkStgBinds :: [StgFloatBind]
+ -> StgExpr -- *Can* be a StgLam
+ -> UniqSM StgExpr -- *Can* be a StgLam
+
+mkStgBinds [] body = returnUs body
+mkStgBinds (b:bs) body
+ = deStgLam body `thenUs` \ body' ->
+ go (b:bs) body'
+ where
+ go [] body = returnUs body
+ go (b:bs) body = go bs body `thenUs` \ body' ->
+ mkStgBind b body'
+
+-- The 'body' arg of mkStgBind can't be a StgLam
+mkStgBind NoBindF body = returnUs body
+mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
+
+mkStgBind (NonRecF bndr rhs dem floats) body
+#ifdef DEBUG
+ -- We shouldn't get let or case of the form v=w
+ = case rhs of
+ StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
+ (mk_stg_let bndr rhs dem floats body)
+ other -> mk_stg_let bndr rhs dem floats body
+
+mk_stg_let bndr rhs dem floats body
+#endif
+ | isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts
+ = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
+ mkStgBinds floats $
+ mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body))
+
+ | is_whnf
+ = if is_strict then
+ -- Strict let with WHNF rhs
+ mkStgBinds floats $
+ StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
+ else
+ -- Lazy let with WHNF rhs; float until we find a strict binding
+ let
+ (floats_out, floats_in) = splitFloats floats
+ in
+ mkStgBinds floats_in rhs `thenUs` \ new_rhs ->
+ mkStgBinds floats_out $
+ StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
+
+ | otherwise -- Not WHNF
+ = if is_strict then
+ -- Strict let with non-WHNF rhs
+ mkStgBinds floats $
+ mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body))
+ else
+ -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
+ mkStgBinds floats rhs `thenUs` \ new_rhs ->
+ returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
+
+ where
+ bndr_rep_ty = repType (idType bndr)
+ is_strict = isStrictDem dem
+ is_whnf = case rhs of
+ StgCon _ _ _ -> True
+ StgLam _ _ _ -> True
+ other -> False
+
+-- Split at the first strict binding
+splitFloats fs@(NonRecF _ _ dem _ : _)
+ | isStrictDem dem = ([], fs)
+
+splitFloats (f : fs) = case splitFloats fs of
+ (fs_out, fs_in) -> (f : fs_out, fs_in)
+
+splitFloats [] = ([], [])