ghc/compiler/deforest/Core2Def.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[Core2Def]{Translate the CoreProgram into a DefProgram}
   5
   6 >#include "HsVersions.h"
   7 >
   8 > module Core2Def (
   9 >       core2def, c2d,
  10 >
  11 >       PlainCoreProgram(..), DefProgram(..),
  12 >       CoreBinding, Id, DefBindee ) where
  13 >
  14 > import DefSyn
  15 >#ifdef __HBC__
  16 > import Trace
  17 >#endif
  18
  19 > import CoreSyn
  20 > import IdEnv
  21 > import PlainCore
  22 > import TaggedCore
  23 > import BinderInfo     -- ( BinderInfo(..), isFun, isDupDanger )
  24 > import CmdLineOpts    ( switchIsOn, SwitchResult, SimplifierSwitch )
  25 > import OccurAnal      ( occurAnalyseBinds )
  26 > import SimplEnv       ( SwitchChecker(..) )
  27 > import Util
  28 > import Pretty
  29 > import Outputable
  30
  31 This module translates the PlainCoreProgram into a DefCoreProgram,
  32 which includes non-atomic right-hand sides.  The decisions about which
  33 expressions to inline are left to the substitution analyser, which we
  34 run beforehand.
  35
  36 Current thinking:
  37
  38 1.  Inline all non-recursive non-top-level lets that occur only
  39     once (including inside lambdas, hoping full laziness
  40     will sort things out later).
  41
  42 2.  We don't inline top-level lets that occur only once, because these
  43     might not be pulled out again by the let-floater, due to non-
  44     garbage collection of CAFs.
  45
  46 2.1.  Also, what about these lit things that occur at the top level,
  47     and are usually marked as macros?
  48
  49 3.  No recusrive functions are unfolded.
  50
  51 ToDo:
  52 4.  Lambdas and case alternatives that bind a variable that occurs
  53     multiple times are transformed:
  54     \x -> ..x..x..  ===>  \x -> let x' = x in ..x'..x'..
  55
  56
  57 > core2def :: (GlobalSwitch -> SwitchResult) -> PlainCoreProgram -> DefProgram
  58 > core2def sw prog =
  59 >       map coreBinding2def tagged_program
  60 >   where
  61 >       tagged_program = occurAnalyseBinds prog switch_is_on (const False)
  62 >       switch_is_on   = switchIsOn sw
  63
  64
  65 > coreBinding2def :: SimplifiableCoreBinding -> DefBinding
  66 > coreBinding2def (CoNonRec (v,_) e) = CoNonRec v (c2d nullIdEnv e)
  67 > coreBinding2def (CoRec bs) = CoRec (map recBind2def bs)
  68 >       where recBind2def ((v,_),e) = (v, c2d nullIdEnv e)
  69
  70
  71 > coreAtom2def :: IdEnv DefExpr -> PlainCoreAtom -> DefAtom
  72 > coreAtom2def p (CoVarAtom v) = CoVarAtom (DefArgExpr (lookup p v))
  73 > coreAtom2def p (CoLitAtom l) = CoVarAtom (DefArgExpr (CoLit l))
  74
  75 > isTrivial (CoCon c [] []) = True
  76 > isTrivial (CoVar v)       = True
  77 > isTrivial (CoLit l)       = True
  78 > isTrivial _               = False
  79
  80 > c2d :: IdEnv DefExpr -> SimplifiableCoreExpr -> DefExpr
  81 > c2d p e = case e of
  82 >
  83 >       CoVar v         -> lookup p v
  84 >
  85 >       CoLit l         -> CoLit l
  86 >
  87 >       CoCon c ts es   -> CoCon c ts (map (coreAtom2def p) es)
  88 >
  89 >       CoPrim op ts es -> CoPrim op ts (map (coreAtom2def p) es)
  90 >
  91 >       CoLam vs e      -> CoLam (map fst vs) (c2d p e)
  92 >
  93 >       CoTyLam alpha e -> CoTyLam alpha (c2d p e)
  94 >
  95 >       CoApp e v       -> CoApp (c2d p e) (coreAtom2def p v)
  96 >
  97 >       CoTyApp e t     -> CoTyApp (c2d p e) t
  98 >
  99 >       CoCase e ps     -> CoCase (c2d p e) (coreCaseAlts2def p ps)
 100 >
 101 >       CoLet (CoNonRec (v,ManyOcc _) e) e'
 102 >               | isTrivial e -> c2d (addOneToIdEnv p v (c2d p e)) e'
 103 >               | otherwise ->
 104 >               trace ("Not inlining ManyOcc " ++ ppShow 80 (ppr PprDebug v)) (
 105 >               CoLet (CoNonRec v (c2d p e)) (c2d p e'))
 106 >
 107 >       CoLet (CoNonRec (v,DeadCode) e) e' ->
 108 >               panic "Core2Def(c2d): oops, unexpected DeadCode"
 109 >
 110 >       CoLet (CoNonRec (v,OneOcc fun_or_arg dup_danger _ _ _) e) e'
 111 >          | isTrivial e -> inline_it
 112 >          | isDupDanger dup_danger ->
 113 >               trace ("Not inlining DupDanger " ++ ppShow 80 (ppr PprDebug v))(
 114 >               CoLet (CoNonRec v (c2d p e)) (c2d p e'))
 115 >          | isFun fun_or_arg ->
 116 >               panic "Core2Def(c2d): oops, unexpected Macro"
 117 >          | otherwise -> inline_it
 118 >        where inline_it = c2d (addOneToIdEnv p v (c2d p e)) e'
 119 >
 120 >       CoLet (CoRec bs) e -> CoLet (CoRec (map recBind2def bs)) (c2d p e)
 121 >               where recBind2def ((v,_),e) = (v, c2d p e)
 122 >
 123 >       CoSCC l e       -> CoSCC l (c2d p e)
 124
 125
 126 > coreCaseAlts2def
 127 >       :: IdEnv DefExpr
 128 >       -> SimplifiableCoreCaseAlternatives
 129 >       -> DefCaseAlternatives
 130 >
 131 > coreCaseAlts2def p alts = case alts of
 132 >       CoAlgAlts as def  -> CoAlgAlts (map algAlt2def as) (defAlt2def def)
 133 >       CoPrimAlts as def -> CoPrimAlts (map primAlt2def as) (defAlt2def def)
 134 >
 135 >   where
 136 >
 137 >       algAlt2def  (c, vs, e) = (c, (map fst vs), c2d p e)
 138 >       primAlt2def (l, e)     = (l, c2d p e)
 139
 140 >       defAlt2def CoNoDefault = CoNoDefault
 141 >       defAlt2def (CoBindDefault (v,_) e) = CoBindDefault v (c2d p e)
 142
 143
 144 > lookup :: IdEnv DefExpr -> Id -> DefExpr
 145 > lookup p v = case lookupIdEnv p v of
 146 >                       Nothing -> CoVar (DefArgVar v)
 147 >                       Just e  -> e