Commit 7bf9669c authored by sewardj's avatar sewardj

[project @ 2002-01-28 17:22:45 by sewardj]

Generate better code for lets whose RHS is a simple fn or constructor
application.  Details are in comment in code.
parent 8de7cb84
......@@ -14,7 +14,7 @@ module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue,
import Outputable
import Name ( Name, getName )
import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, isFCallId,
idPrimRep, mkSysLocal, idName, isFCallId_maybe )
idPrimRep, mkSysLocal, idName, isFCallId_maybe, isPrimOpId )
import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
nilOL, toOL, concatOL, fromOL )
......@@ -308,6 +308,99 @@ schemeE d s p (fvs, AnnLit literal)
`appOL` mkSLIDE szw (d-s) -- clear to sequel
`snocOL` RETURN l_rep) -- go
{-
Deal specially with the cases
let x = fn atom1 .. atomn in B
and
let x = Con atom1 .. atomn in B
(Con must be saturated, and atom1 .. n must be ptr-rep'd)
In these cases, generate code to allocate in-line. The ptr-rep'd
restriction avoids the problem of having to reorder constructor
args.
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. 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 order_in_which_to_push `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)
| all isPtrRepdVar args_r_to_l
&& 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)
isPtrRepdVar (_, AnnVar v) = isFollowableRep (idPrimRep v)
isPtrRepdVar (_, AnnNote n e) = isPtrRepdVar e
isPtrRepdVar (_, AnnApp f (_, AnnType _)) = isPtrRepdVar f
isPtrRepdVar _ = False
-- Extract the args (R -> L) and fn
order_in_which_to_push = map snd args_r_to_l
(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)
args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw
isTypeAtom (AnnType _) = True
isTypeAtom _ = False
-- 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
mkPushes :: Int{-curr depth-} -> [AnnExpr' Id VarSet]
-> BcM (Int{-final depth-}, BCInstrList)
mkPushes dd []
| is_con
= returnBc (dd, nilOL)
| otherwise
= pushAtom True dd p' (AnnVar the_fn) `thenBc` \ (fn_push_code, fn_szw) ->
returnBc (dd+fn_szw, fn_push_code)
mkPushes dd (atom:atoms)
= pushAtom True dd p' atom `thenBc` \ (push1_code, push1_szw) ->
mkPushes (dd+push1_szw) atoms `thenBc` \ (dd_final, push_rest) ->
returnBc (dd_final, push1_code `appOL` push_rest)
-- General case for let. Generates correct, if inefficient, code in
-- all situations.
schemeE d s p (fvs, AnnLet binds b)
= let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
AnnRec xs_n_rhss -> unzip xs_n_rhss
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment