ghc/compiler/deforest/Deforest.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
   3 %
   4 \section[Deforest]{Top level deforestation module}
   5
   6 >#include "HsVersions.h"
   7 >
   8 > module Deforest (
   9 >       deforestProgram
  10 >       ) where
  11
  12 > import Core2Def
  13 > import Def2Core
  14 > import DefUtils
  15 > import DefSyn
  16 > import DefExpr
  17 > import Cyclic
  18 > import TreelessForm
  19 >#ifdef __HBC__
  20 > import Trace
  21 >#endif
  22
  23 > import CmdLineOpts    ( GlobalSwitch, SwitchResult )
  24 > import CoreSyn
  25 > import Id             ( getIdInfo, Id )
  26 > import IdEnv
  27 > import IdInfo
  28 > import Outputable
  29 > import SimplEnv       ( SwitchChecker(..) )
  30 > import SplitUniq
  31 > import TyVarEnv
  32 > import Util
  33
  34 > -- tmp, for traces
  35 > import Pretty
  36
  37 > -- stub (ToDo)
  38 > domIdEnv = panic "Deforest: domIdEnv"
  39
  40 > deforestProgram
  41 >       :: SwitchChecker GlobalSwitch{-maybe-}
  42 >       -> PlainCoreProgram
  43 >       -> SplitUniqSupply
  44 >       -> PlainCoreProgram
  45 >
  46 > deforestProgram sw prog uq =
  47 >       let
  48 >               def_program = core2def sw prog
  49 >               out_program = (
  50 >                       defProg sw nullIdEnv def_program  `thenSUs` \prog ->
  51 >                       def2core prog)
  52 >                       uq
  53 >       in
  54 >               out_program
  55
  56 We have to collect all the unfoldings (functions that were annotated
  57 with DEFOREST) and pass them in an environment to subsequent calls of
  58 the transformer.
  59
  60 Recursive functions are first transformed by the deforester.  If the
  61 function is annotated as deforestable, then it is converted to
  62 treeless form for unfolding later on.
  63
  64 Also converting non-recursive functions that are annotated with
  65 {-# DEFOREST #-} now.  Probably don't need to convert these to treeless
  66 form: just the inner recursive bindings they contain.  eg:
  67
  68 repeat = \x -> letrec xs = x:xs in xs
  69
  70 is non-recursive, but we want to unfold it and annotate the binding
  71 for xs as unfoldable, too.
  72
  73 > defProg
  74 >       :: SwitchChecker GlobalSwitch{-maybe-}
  75 >       -> IdEnv DefExpr
  76 >       -> [DefBinding]
  77 >       -> SUniqSM [DefBinding]
  78 >
  79 > defProg sw p [] = returnSUs []
  80 >
  81 > defProg sw p (CoNonRec v e : bs) =
  82 >       trace ("Processing: `" ++
  83 >                       ppShow 80 (ppr PprDebug v) ++ "'\n") (
  84 >       tran sw p nullTyVarEnv e []             `thenSUs` \e ->
  85 >       mkLoops e                               `thenSUs` \(extracted,e) ->
  86 >       let e' = mkDefLetrec extracted e in
  87 >       (
  88 >         if deforestable v then
  89 >               let (vs,es) = unzip extracted in
  90 >               convertToTreelessForm sw e      `thenSUs` \e ->
  91 >               mapSUs (convertToTreelessForm sw) es    `thenSUs` \es ->
  92 >               defProg sw (growIdEnvList p ((v,e):zip vs es)) bs
  93 >         else
  94 >               defProg sw p bs
  95 >       )                                       `thenSUs` \bs ->
  96 >       returnSUs (CoNonRec v e' : bs)
  97 >       )
  98 >
  99 > defProg sw p (CoRec bs : bs') =
 100 >       mapSUs (defRecBind sw p) bs             `thenSUs` \res  ->
 101 >       let
 102 >               (resid, unfold) = unzip res
 103 >               p' = growIdEnvList p (concat unfold)
 104 >       in
 105 >       defProg sw p' bs'                       `thenSUs` \bs' ->
 106 >       returnSUs (CoRec resid: bs')
 107
 108
 109 > defRecBind
 110 >       :: SwitchChecker GlobalSwitch{-maybe-}
 111 >       -> IdEnv DefExpr
 112 >       -> (Id,DefExpr)
 113 >       -> SUniqSM ((Id,DefExpr),[(Id,DefExpr)])
 114 >
 115 > defRecBind sw p (v,e) =
 116 >       trace ("Processing: `" ++
 117 >                       ppShow 80 (ppr PprDebug v) ++ "'\n") (
 118 >       tran sw p nullTyVarEnv e []             `thenSUs` \e' ->
 119 >       mkLoops e'                              `thenSUs` \(bs,e') ->
 120 >       let e'' = mkDefLetrec bs e' in
 121 >
 122 >       d2c e'' `thenSUs` \core_e ->
 123 >       let showBind (v,e) = ppShow 80 (ppr PprDebug v) ++
 124 >               "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n"
 125 >       in
 126 >       trace ("Extracting from `" ++
 127 >               ppShow 80 (ppr PprDebug v) ++ "'\n"
 128 >               ++ "{ result:\n" ++ showBind (v,core_e) ++ "}\n") $
 129 >
 130 >       if deforestable v
 131 >               then
 132 >                       let (vs,es) = unzip bs in
 133 >                       convertToTreelessForm sw e'     `thenSUs` \e' ->
 134 >                       mapSUs (convertToTreelessForm sw) es `thenSUs` \es ->
 135 >                       returnSUs ((v,e''),(v,e'):zip vs es)
 136 >               else
 137 >                       trace (show (length bs)) (
 138 >                       returnSUs ((v,e''),[])
 139 >                       )
 140 >       )