schemeR_wrk: look through tyapps when spotting top-level nullary
constructor uses. Fixes bug reported by Mark Tehver:
<<loop>> in GHC 5.01 "Zarjaz"
where
maybe_toplevel_null_con_rhs
| is_top && null args
where
maybe_toplevel_null_con_rhs
| is_top && null args
+ = case nukeTyArgs (snd body) of
AnnVar v_wrk
-> case isDataConId_maybe v_wrk of
Nothing -> Nothing
AnnVar v_wrk
-> case isDataConId_maybe v_wrk of
Nothing -> Nothing
+ nukeTyArgs (AnnApp f (_, AnnType _)) = nukeTyArgs (snd f)
+ nukeTyArgs other = other
+
+
-- Let szsw be the sizes in words of some items pushed onto the stack,
-- which has initial depth d'. Return the values which the stack environment
-- should map these items to.
-- Let szsw be the sizes in words of some items pushed onto the stack,
-- which has initial depth d'. Return the values which the stack environment
-- should map these items to.
-- (the VoidRep takes up zero stack space). Also, spot
-- (# b #) and treat it as b.
--
-- (the VoidRep takes up zero stack space). Also, spot
-- (# b #) and treat it as b.
--
--- 3. Application of a non-nullary constructor, by defn saturated.
+-- 3. The fn denotes a ccall. Defer to generateCCall.
+--
+-- 4. Application of a non-nullary constructor, by defn saturated.
-- Split the args into ptrs and non-ptrs, and push the nonptrs,
-- then the ptrs, and then do PACK and RETURN.
--
-- Split the args into ptrs and non-ptrs, and push the nonptrs,
-- then the ptrs, and then do PACK and RETURN.
--
--- 4. Otherwise, it must be a function call. Push the args
+-- 5. Otherwise, it must be a function call. Push the args
-- right to left, SLIDE and ENTER.
schemeT :: Int -- Stack depth
-- right to left, SLIDE and ENTER.
schemeT :: Int -- Stack depth
-- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate app)) ++ "\n") False
-- = error "?!?!"
-- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate app)) ++ "\n") False
-- = error "?!?!"
| Just (arg, constr_names) <- maybe_is_tagToEnum_call
= pushAtom True d p arg `thenBc` \ (push, arg_words) ->
implement_tagToId constr_names `thenBc` \ tagToId_sequence ->
| Just (arg, constr_names) <- maybe_is_tagToEnum_call
= pushAtom True d p arg `thenBc` \ (push, arg_words) ->
implement_tagToId constr_names `thenBc` \ tagToId_sequence ->
`appOL` mkSLIDE 1 (d+arg_words-s)
`snocOL` ENTER)
`appOL` mkSLIDE 1 (d+arg_words-s)
`snocOL` ENTER)
| is_con_call && null args_r_to_l
= returnBc (
(PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s))
`snocOL` ENTER
)
| is_con_call && null args_r_to_l
= returnBc (
(PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s))
`snocOL` ENTER
)
| let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v)
isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e
in is_con_call && isUnboxedTupleCon con
| let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v)
isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e
in is_con_call && isUnboxedTupleCon con
schemeT d s p (head args_r_to_l)
--)
schemeT d s p (head args_r_to_l)
--)
| Just (CCall ccall_spec) <- isFCallId_maybe fn
= generateCCall d s p ccall_spec fn args_r_to_l
| Just (CCall ccall_spec) <- isFCallId_maybe fn
= generateCCall d s p ccall_spec fn args_r_to_l
| otherwise
= if is_con_call && isUnboxedTupleCon con
then unboxedTupleException
| otherwise
= if is_con_call && isUnboxedTupleCon con
then unboxedTupleException