-#if 0
-{-
- Disabled for now --SDM (TODO: reinstate later, but do it better)
-
- Deal specially with the cases
- let x = fn atom1 .. atomn in B
- and
- let x = Con atom1 .. atomn in B
- (Con must be saturated)
-
- In these cases, generate code to allocate in-line.
-
- This is optimisation of the general case for let, which follows
- this one; this case can safely be omitted. The reduction in
- interpreter execution time seems to be around 5% for some programs,
- with a similar drop in allocations.
-
- This optimisation should be done more cleanly. As-is, it is
- inapplicable to RHSs in letrecs, and needlessly duplicates code in
- schemeR and schemeT. Some refactoring of the machinery would cure
- both ills.
--}
-schemeE d s p ee@(fvs, AnnLet (AnnNonRec x rhs) b)
- | ok_to_go
- = let d_init = if is_con then d else d'
- in
- mkPushes d_init args_r_to_l_reordered `thenBc` \ (d_final, push_code) ->
- schemeE d' s p' b `thenBc` \ body_code ->
- let size = d_final - d_init
- alloc = if is_con then nilOL else unitOL (ALLOC size)
- pack = unitOL (if is_con then PACK the_dcon size else MKAP size size)
- in
- returnBc (alloc `appOL` push_code `appOL` pack
- `appOL` body_code)
- where
- -- Decide whether we can do this or not
- (ok_to_go, is_con, the_dcon, the_fn)
- = case maybe_fn of
- Nothing -> (False, bomb 1, bomb 2, bomb 3)
- Just (Left fn) -> (True, False, bomb 5, fn)
- Just (Right dcon)
- | dataConRepArity dcon <= length args_r_to_l
- -> (True, True, dcon, bomb 6)
- | otherwise
- -> (False, bomb 7, bomb 8, bomb 9)
- bomb n = panic ("schemeE.is_con(hacky hack hack) " ++ show n)
-
- -- Extract the args (R -> L) and fn
- args_r_to_l_reordered
- | not is_con
- = args_r_to_l
- | otherwise
- = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l
- where isPtr = isFollowableRep . atomRep
-
- args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw
- isTypeAtom (AnnType _) = True
- isTypeAtom _ = False
-
- (args_r_to_l_raw, maybe_fn) = chomp rhs
- chomp expr
- = case snd expr of
- AnnVar v
- | isFCallId v || isPrimOpId v
- -> ([], Nothing)
- | otherwise
- -> case isDataConId_maybe v of
- Just dcon -> ([], Just (Right dcon))
- Nothing -> ([], Just (Left v))
- AnnApp f a -> case chomp f of (az, f) -> (a:az, f)
- AnnNote n e -> chomp e
- other -> ([], Nothing)
-
- -- This is the env in which to translate the body
- p' = addToFM p x d
- d' = d + 1
-
- -- Shove the args on the stack, including the fn in the non-dcon case
- tag_when_push = not is_con
-
-#endif
+schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
+ | (AnnVar v, args_r_to_l) <- splitApp rhs,
+ Just data_con <- isDataConWorkId_maybe v,
+ dataConRepArity data_con == length args_r_to_l
+ = -- Special case for a non-recursive let whose RHS is a
+ -- saturatred constructor application.
+ -- Just allocate the constructor and carry on
+ mkConAppCode d s p data_con args_r_to_l `thenBc` \ alloc_code ->
+ schemeE (d+1) s (addToFM p x d) body `thenBc` \ body_code ->
+ returnBc (alloc_code `appOL` body_code)