[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.

diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index c5374da..55f0da8 100644 (file)
--- a/ghc/compiler/ghci/ByteCodeGen.lhs
+++ b/ghc/compiler/ghci/ByteCodeGen.lhs
@@ -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