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 IdInfo
  27 > import Outputable
  28 > import SimplEnv       ( SwitchChecker(..) )
  29 > import UniqSupply
  30 > import Util
  31
  32 > -- tmp, for traces
  33 > import Pretty
  34
  35 > -- stub (ToDo)
  36 > domIdEnv = panic "Deforest: domIdEnv"
  37
  38 > deforestProgram
  39 >       :: SwitchChecker GlobalSwitch{-maybe-}
  40 >       -> [CoreBinding]
  41 >       -> UniqSupply
  42 >       -> [CoreBinding]
  43 >
  44 > deforestProgram sw prog uq =
  45 >       let
  46 >               def_program = core2def sw prog
  47 >               out_program = (
  48 >                       defProg sw nullIdEnv def_program  `thenUs` \prog ->
  49 >                       def2core prog)
  50 >                       uq
  51 >       in
  52 >               out_program
  53
  54 We have to collect all the unfoldings (functions that were annotated
  55 with DEFOREST) and pass them in an environment to subsequent calls of
  56 the transformer.
  57
  58 Recursive functions are first transformed by the deforester.  If the
  59 function is annotated as deforestable, then it is converted to
  60 treeless form for unfolding later on.
  61
  62 Also converting non-recursive functions that are annotated with
  63 {-# DEFOREST #-} now.  Probably don't need to convert these to treeless
  64 form: just the inner recursive bindings they contain.  eg:
  65
  66 repeat = \x -> letrec xs = x:xs in xs
  67
  68 is non-recursive, but we want to unfold it and annotate the binding
  69 for xs as unfoldable, too.
  70
  71 > defProg
  72 >       :: SwitchChecker GlobalSwitch{-maybe-}
  73 >       -> IdEnv DefExpr
  74 >       -> [DefBinding]
  75 >       -> UniqSM [DefBinding]
  76 >
  77 > defProg sw p [] = returnUs []
  78 >
  79 > defProg sw p (NonRec v e : bs) =
  80 >       trace ("Processing: `" ++
  81 >                       ppShow 80 (ppr PprDebug v) ++ "'\n") (
  82 >       tran sw p nullTyVarEnv e []             `thenUs` \e ->
  83 >       mkLoops e                               `thenUs` \(extracted,e) ->
  84 >       let e' = mkDefLetrec extracted e in
  85 >       (
  86 >         if deforestable v then
  87 >               let (vs,es) = unzip extracted in
  88 >               convertToTreelessForm sw e      `thenUs` \e ->
  89 >               mapUs (convertToTreelessForm sw) es     `thenUs` \es ->
  90 >               defProg sw (growIdEnvList p ((v,e):zip vs es)) bs
  91 >         else
  92 >               defProg sw p bs
  93 >       )                                       `thenUs` \bs ->
  94 >       returnUs (NonRec v e' : bs)
  95 >       )
  96 >
  97 > defProg sw p (Rec bs : bs') =
  98 >       mapUs (defRecBind sw p) bs              `thenUs` \res  ->
  99 >       let
 100 >               (resid, unfold) = unzip res
 101 >               p' = growIdEnvList p (concat unfold)
 102 >       in
 103 >       defProg sw p' bs'                       `thenUs` \bs' ->
 104 >       returnUs (Rec resid: bs')
 105
 106
 107 > defRecBind
 108 >       :: SwitchChecker GlobalSwitch{-maybe-}
 109 >       -> IdEnv DefExpr
 110 >       -> (Id,DefExpr)
 111 >       -> UniqSM ((Id,DefExpr),[(Id,DefExpr)])
 112 >
 113 > defRecBind sw p (v,e) =
 114 >       trace ("Processing: `" ++
 115 >                       ppShow 80 (ppr PprDebug v) ++ "'\n") (
 116 >       tran sw p nullTyVarEnv e []             `thenUs` \e' ->
 117 >       mkLoops e'                              `thenUs` \(bs,e') ->
 118 >       let e'' = mkDefLetrec bs e' in
 119 >
 120 >       d2c e'' `thenUs` \core_e ->
 121 >       let showBind (v,e) = ppShow 80 (ppr PprDebug v) ++
 122 >               "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n"
 123 >       in
 124 >       trace ("Extracting from `" ++
 125 >               ppShow 80 (ppr PprDebug v) ++ "'\n"
 126 >               ++ "{ result:\n" ++ showBind (v,core_e) ++ "}\n") $
 127 >
 128 >       if deforestable v
 129 >               then
 130 >                       let (vs,es) = unzip bs in
 131 >                       convertToTreelessForm sw e'     `thenUs` \e' ->
 132 >                       mapUs (convertToTreelessForm sw) es `thenUs` \es ->
 133 >                       returnUs ((v,e''),(v,e'):zip vs es)
 134 >               else
 135 >                       trace (show (length bs)) (
 136 >                       returnUs ((v,e''),[])
 137 >                       )
 138 >       )