ghc/compiler/ndpFlatten/Flattening.hs

   1 --  $Id$
   2 --
   3 --  Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller
   4 --
   5 --  Vectorisation and lifting
   6 --
   7 --- DESCRIPTION ---------------------------------------------------------------
   8 --
   9 --  This module implements the vectorisation and function lifting
  10 --  transformations of the flattening transformation.
  11 --
  12 --- DOCU ----------------------------------------------------------------------
  13 --
  14 --  Language: Haskell 98 with C preprocessor
  15 --
  16 --  Types:
  17 --    the transformation on types has five purposes:
  18 --
  19 --        1) for each type definition, derive the lifted version of this type
  20 --             liftTypeef
  21 --        2) change the type annotations of functions & variables acc. to rep.
  22 --             flattenType
  23 --        3) derive the type of a lifted function
  24 --             liftType
  25 --        4) sumtypes:
  26 --             this is the most fuzzy and complicated part. For each lifted
  27 --             sumtype we need to generate function to access and combine the
  28 --             component arrays
  29 --
  30 --   NOTE: the type information of variables and data constructors is *not*
  31 --          changed to reflect it's representation. This has to be solved
  32 --          somehow (???, FIXME)  using type indexed types
  33 --
  34 --   Vectorisation:
  35 --    is very naive at the moment. One of the most striking inefficiencies is
  36 --    application vect (app e1 e2) -> app (fst (vect e1) (vect e2)) if e1 is a
  37 --    lambda abstraction. The vectorisation produces a pair consisting of the
  38 --    original and the lifted function, but the lifted version is discarded.
  39 --    I'm also not sure how much of this would be thrown out by the simplifier
  40 --    eventually
  41 --
  42 --        *) vectorise
  43 --
  44 --  Conventions:
  45 --
  46 --- TODO ----------------------------------------------------------------------
  47 --
  48 --   * look closer into the definition of type definition (TypeThing or so)
  49 --
  50
  51 module Flattening (
  52   flatten, flattenExpr,
  53 ) where
  54
  55 #include "HsVersions.h"
  56
  57 -- friends
  58 import NDPCoreUtils (tupleTyArgs, funTyArgs, parrElemTy, isDefault,
  59                      isLit, mkPArrTy, mkTuple, isSimpleExpr, substIdEnv)
  60 import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
  61                      liftVar, liftConst, intersectWithContext, mk'fst,
  62                      mk'lengthP, mk'replicateP, mk'mapP, mk'bpermuteDftP,
  63                      mk'indexOfP,mk'eq,mk'neq)
  64
  65 -- GHC
  66 import CmdLineOpts  (opt_Flatten)
  67 import Panic        (panic)
  68 import ErrUtils     (dumpIfSet_dyn)
  69 import UniqSupply   (mkSplitUniqSupply)
  70 import CmdLineOpts  (DynFlag(..))
  71 import Literal      (Literal, literalType)
  72 import Var          (Var(..), idType, isTyVar)
  73 import Id           (setIdType)
  74 import DataCon      (DataCon, dataConTag)
  75 import TypeRep      (Type(..))
  76 import HscTypes     ( ModGuts(..), ModGuts, HscEnv(..), hscEPS )
  77 import CoreFVs      (exprFreeVars)
  78 import CoreSyn      (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..),
  79                      CoreBndr, CoreExpr, CoreBind, mkLams, mkLets,
  80                      mkApps, mkIntLitInt)
  81 import PprCore      (pprCoreExpr)
  82 import CoreLint     (showPass, endPass)
  83
  84 import CoreUtils    (exprType, applyTypeToArg, mkPiType)
  85 import VarEnv       (zipVarEnv)
  86 import TysWiredIn   (mkTupleTy)
  87 import BasicTypes   (Boxity(..))
  88 import Outputable
  89 import FastString
  90
  91
  92 -- FIXME: fro debugging - remove this
  93 import TRACE    (trace)
  94
  95 -- standard
  96 import Monad        (liftM, foldM)
  97
  98 -- toplevel transformation
  99 -- -----------------------
 100
 101 -- entry point to the flattening transformation for the compiler driver when
 102 -- compiling a complete module (EXPORTED)
 103 --
 104 flatten :: HscEnv
 105         -> ModGuts
 106         -> IO ModGuts
 107 flatten hsc_env mod_impl@(ModGuts {mg_binds = binds})
 108   | not opt_Flatten = return mod_impl -- skip without -fflatten
 109   | otherwise       =
 110   do
 111     let dflags = hsc_dflags hsc_env
 112
 113     eps <- hscEPS hsc_env
 114     us <- mkSplitUniqSupply 'l'         -- 'l' as in fLattening
 115     --
 116     -- announce vectorisation
 117     --
 118     showPass dflags "Flattening [first phase: vectorisation]"
 119     --
 120     -- vectorise all toplevel bindings
 121     --
 122     let binds' = runFlatten hsc_env eps us $ vectoriseTopLevelBinds binds
 123     --
 124     -- and dump the result if requested
 125     --
 126     endPass dflags "Flattening [first phase: vectorisation]"
 127             Opt_D_dump_vect binds'
 128     return $ mod_impl {mg_binds = binds'}
 129
 130 -- entry point to the flattening transformation for the compiler driver when
 131 -- compiling a single expression in interactive mode (EXPORTED)
 132 --
 133 flattenExpr :: HscEnv
 134             -> CoreExpr                 -- the expression to be flattened
 135             -> IO CoreExpr
 136 flattenExpr hsc_env expr
 137   | not opt_Flatten = return expr       -- skip without -fflatten
 138   | otherwise       =
 139   do
 140     let dflags = hsc_dflags hsc_env
 141     eps <- hscEPS hsc_env
 142
 143     us <- mkSplitUniqSupply 'l'         -- 'l' as in fLattening
 144     --
 145     -- announce vectorisation
 146     --
 147     showPass dflags "Flattening [first phase: vectorisation]"
 148     --
 149     -- vectorise the expression
 150     --
 151     let expr' = fst . runFlatten hsc_env eps us $ vectorise expr
 152     --
 153     -- and dump the result if requested
 154     --
 155     dumpIfSet_dyn dflags Opt_D_dump_vect "Vectorised expression"
 156                   (pprCoreExpr expr')
 157     return expr'
 158
 159
 160 -- vectorisation of bindings and expressions
 161 -- -----------------------------------------
 162
 163
 164 vectoriseTopLevelBinds:: [CoreBind] -> Flatten [CoreBind]
 165 vectoriseTopLevelBinds binds =
 166   do
 167     vbinds <- mapM vectoriseBind binds
 168     return (adjustTypeBinds vbinds)
 169
 170 adjustTypeBinds:: [CoreBind] -> [CoreBind]
 171 adjustTypeBinds vbinds =
 172     let
 173        ids = concat (map extIds vbinds)
 174        idEnv =  zipVarEnv ids ids
 175      in map (substIdEnvBind idEnv) vbinds
 176   where
 177     -- FIXME replace by 'bindersOf'
 178     extIds (NonRec b expr) = [b]
 179     extIds (Rec      bnds) = map fst bnds
 180     substIdEnvBind idEnv (NonRec b expr) = NonRec b (substIdEnv idEnv expr)
 181     substIdEnvBind idEnv (Rec bnds)
 182        = Rec (map (\ (b,e) -> (b, (substIdEnv idEnv e))) bnds)
 183
 184 -- vectorise a single core binder
 185 --
 186 vectoriseBind                 :: CoreBind -> Flatten CoreBind
 187 vectoriseBind (NonRec b expr)  =
 188   liftM (NonRec b) $ liftM fst $ vectorise expr
 189 vectoriseBind (Rec bindings)   =
 190   liftM Rec        $ mapM vectoriseOne bindings
 191   where
 192     vectoriseOne (b, expr) =
 193       do
 194         (vexpr, ty) <- vectorise expr
 195         return (setIdType b ty, vexpr)
 196
 197
 198 -- Searches for function definitions and creates a lifted version for
 199 -- each function.
 200 -- We have only two interesting cases:
 201 -- 1) function application  (ex1) (ex2)
 202 --      vectorise both subexpressions. The function will end up becoming a
 203 --      pair (orig. fun, lifted fun), choose first component (in many cases,
 204 --      this is pretty inefficient, since the lifted version is generated
 205 --      although it is clear that it won't be used
 206 --
 207 -- 2) lambda abstraction
 208 --      any function has to exist in two forms: it's original form and it's
 209 --      lifted form. Therefore, every lambda abstraction is transformed into
 210 --      a pair of functions: the original function and its lifted variant
 211 --
 212 --
 213 --  FIXME: currently, I use 'exprType' all over the place - this is terribly
 214 --  inefficient. It should be suffiecient to change 'vectorise' and 'lift' to
 215 --  return the type of the result expression as well.
 216 --
 217 vectorise:: CoreExpr -> Flatten (CoreExpr, Type)
 218 vectorise (Var id)  =
 219   do
 220     let varTy  = idType id
 221     let vecTy  = vectoriseTy varTy
 222     return (Var (setIdType id vecTy), vecTy)
 223
 224 vectorise (Lit lit) =
 225   return ((Lit lit), literalType lit)
 226
 227
 228 vectorise e@(App expr t@(Type _)) =
 229   do
 230     (vexpr, vexprTy) <- vectorise expr
 231     return ((App vexpr t), applyTypeToArg vexprTy t)
 232
 233 vectorise  (App (Lam b expr) arg) =
 234   do
 235     (varg, argTy)    <- vectorise arg
 236     (vexpr, vexprTy) <- vectorise expr
 237     let vb            = setIdType b argTy
 238     return ((App (Lam vb  vexpr) varg),
 239             applyTypeToArg (mkPiType vb vexprTy) varg)
 240
 241 -- if vexpr expects a type as first argument
 242 -- application stays just as it is
 243 --
 244 vectorise (App expr arg) =
 245   do
 246     (vexpr, vexprTy) <-  vectorise expr
 247     (varg,  vargTy)  <-  vectorise arg
 248
 249     if (isPolyType vexprTy)
 250       then do
 251         let resTy =  applyTypeToArg vexprTy varg
 252         return (App vexpr varg, resTy)
 253       else do
 254         let [t1, t2] = tupleTyArgs  vexprTy
 255         vexpr'      <-  mk'fst t1 t2 vexpr
 256         let resTy    = applyTypeToArg t1 varg
 257         return  ((App vexpr' varg), resTy)  -- apply the first component of
 258                                             -- the vectorized function
 259   where
 260     isPolyType t =
 261         (case t  of
 262            (ForAllTy _ _)  -> True
 263            (NoteTy _ nt)   -> isPolyType nt
 264            _               -> False)
 265
 266
 267 vectorise  e@(Lam b expr)
 268   | isTyVar b
 269   =  do
 270         (vexpr, vexprTy) <- vectorise expr          -- don't vectorise 'b'!
 271         return ((Lam b vexpr), mkPiType b vexprTy)
 272   | otherwise =
 273      do
 274        (vexpr, vexprTy)  <- vectorise expr
 275        let vb             = setIdType b (vectoriseTy (idType b))
 276        let ve             =  Lam  vb  vexpr
 277        (lexpr, lexprTy)  <- lift e
 278        let veTy = mkPiType vb vexprTy
 279        return $ (mkTuple [veTy, lexprTy] [ve, lexpr],
 280                  mkTupleTy Boxed 2 [veTy, lexprTy])
 281
 282 vectorise (Let bind body) =
 283   do
 284     vbind            <- vectoriseBind bind
 285     (vbody, vbodyTy) <- vectorise body
 286     return ((Let vbind vbody), vbodyTy)
 287
 288 vectorise (Case expr b ty alts) =
 289   do
 290     (vexpr, vexprTy) <- vectorise expr
 291     valts <- mapM vectorise' alts
 292     let res_ty = snd (head valts)
 293     return (Case vexpr (setIdType b vexprTy) res_ty (map fst valts), res_ty)
 294   where vectorise' (con, bs, expr) =
 295           do
 296             (vexpr, vexprTy) <- vectorise expr
 297             return ((con, bs, vexpr), vexprTy)  -- FIXME: change type of con
 298                                                 --   and bs
 299
 300
 301
 302 vectorise (Note note expr) =
 303  do
 304    (vexpr, vexprTy) <- vectorise expr        -- FIXME: is this ok or does it
 305    return ((Note note vexpr), vexprTy)       --   change the validity of note?
 306
 307 vectorise e@(Type t) =
 308   return (e, t)                              -- FIXME: panic instead of 't'???
 309
 310
 311 {-
 312 myShowTy (TyVarTy _) = "TyVar "
 313 myShowTy (AppTy t1 t2) =
 314   "AppTy (" ++ (myShowTy t1) ++ ", " ++ (myShowTy t2) ++ ")"
 315 myShowTy (TyConApp _ t) =
 316   "TyConApp TC (" ++ (myShowTy t) ++ ")"
 317 -}
 318
 319 vectoriseTy :: Type -> Type
 320 vectoriseTy t@(TyVarTy v)      =  t
 321 vectoriseTy t@(AppTy t1 t2)    =
 322   AppTy (vectoriseTy t1) (vectoriseTy t2)
 323 vectoriseTy t@(TyConApp tc ts) =
 324   TyConApp tc (map vectoriseTy ts)
 325 vectoriseTy t@(FunTy t1 t2)    =
 326   mkTupleTy Boxed 2 [(FunTy (vectoriseTy t1) (vectoriseTy t2)),
 327                      (liftTy t)]
 328 vectoriseTy  t@(ForAllTy v ty)  =
 329   ForAllTy v (vectoriseTy  ty)
 330 vectoriseTy t@(NoteTy note ty) =  -- FIXME: is the note still valid after
 331   NoteTy note  (vectoriseTy ty)   --   this or should we just throw it away
 332 vectoriseTy  t =  t
 333
 334
 335 -- liftTy: wrap the type in an array but be careful with function types
 336 --    on the *top level* (is this sufficient???)
 337
 338 liftTy:: Type -> Type
 339 liftTy (FunTy t1 t2)   = FunTy (liftTy t1) (liftTy t2)
 340 liftTy (ForAllTy tv t) = ForAllTy tv (liftTy t)
 341 liftTy (NoteTy n t)    = NoteTy n $ liftTy t
 342 liftTy  t              = mkPArrTy t
 343
 344
 345 --  lifting:
 346 -- ----------
 347 --  * liftType
 348 --  * lift
 349
 350
 351 -- liftBinderType: Converts a  type 'a' stored in the binder to the
 352 -- representation of '[:a:]' will therefore call liftType
 353 --
 354 --  lift type, don't change name (incl unique) nor IdInfo. IdInfo looks ok,
 355 --  but I'm not entirely sure about some fields (e.g., strictness info)
 356 liftBinderType:: CoreBndr ->  Flatten CoreBndr
 357 liftBinderType bndr = return $  setIdType bndr (liftTy (idType bndr))
 358
 359 -- lift: lifts an expression (a -> [:a:])
 360 -- If the expression is a simple expression, it is treated like a constant
 361 -- expression.
 362 -- If the body of a lambda expression is a simple expression, it is
 363 -- transformed into a mapP
 364 lift:: CoreExpr -> Flatten (CoreExpr, Type)
 365 lift cExpr@(Var id)    =
 366   do
 367     lVar@(Var lId) <- liftVar id
 368     return (lVar, idType lId)
 369
 370 lift cExpr@(Lit lit)   =
 371   do
 372     lLit  <- liftConst cExpr
 373     return (lLit, exprType lLit)
 374
 375
 376 lift (Lam b expr)
 377   | isSimpleExpr expr      =  liftSimpleFun b expr
 378   | isTyVar b =
 379     do
 380       (lexpr, lexprTy) <- lift expr  -- don't lift b!
 381       return (Lam b lexpr, mkPiType b lexprTy)
 382   | otherwise =
 383     do
 384       lb               <- liftBinderType b
 385       (lexpr, lexprTy) <- extendContext [lb] (lift expr)
 386       return ((Lam lb lexpr) , mkPiType lb lexprTy)
 387
 388 lift (App expr1 expr2) =
 389   do
 390     (lexpr1, lexpr1Ty) <- lift expr1
 391     (lexpr2, _)        <- lift expr2
 392     return ((App lexpr1 lexpr2), applyTypeToArg lexpr1Ty lexpr2)
 393
 394
 395 lift (Let (NonRec b expr1) expr2)
 396   |isSimpleExpr expr2 =
 397     do
 398       (lexpr1, _)        <- lift expr1
 399       (lexpr2, lexpr2Ty) <- liftSimpleFun b expr2
 400       let (t1, t2) = funTyArgs lexpr2Ty
 401       liftM (\x -> (x, liftTy t2)) $  mk'mapP t1 t2 lexpr2 lexpr1
 402
 403   | otherwise =
 404     do
 405       (lexpr1, _)        <- lift expr1
 406       lb                 <- liftBinderType b
 407       (lexpr2, lexpr2Ty) <- extendContext [lb] (lift expr1)
 408       return ((Let (NonRec lb lexpr1) lexpr2), lexpr2Ty)
 409
 410 lift (Let (Rec binds) expr2) =
 411   do
 412     let (bndVars, exprs)  = unzip binds
 413     lBndVars           <- mapM liftBinderType bndVars
 414     lexprs             <- extendContext bndVars (mapM lift exprs)
 415     (lexpr2, lexpr2Ty) <- extendContext bndVars (lift expr2)
 416     return ((Let (Rec (zip  lBndVars (map fst lexprs))) lexpr2), lexpr2Ty)
 417
 418 -- FIXME:
 419 -- Assumption: alternatives can either be literals or data construtors.
 420 --             Due to type restrictions, I don't think it is possible
 421 --             that they are mixed.
 422 --             The handling of literals and data constructors is completely
 423 --             different
 424 --
 425 --
 426 -- let b = expr in alts
 427 --
 428 -- I think I read somewhere that the default case (if present) is stored
 429 -- in the head of the list. Assume for now this is true, have to check
 430 --
 431 -- (1) literals
 432 -- (2) data constructors
 433 --
 434 -- FIXME: optimisation: first, filter out all simple expression and
 435 --   loop (mapP & filter) over all the corresponding values in a single
 436 --   traversal:
 437
 438 --    (1) splitAlts:: [Alt CoreBndr] -> ([Alt CoreBndr],[Alt CoreBndr])
 439 --                                       simple alts     reg alts
 440 --    (2) if simpleAlts = [] then (just as before)
 441 --        if regAlts    = [] then (the whole thing is just a loop)
 442 --        otherwise (a) compute index vector for simpleAlts (for def permute
 443 --                      later on
 444 --                  (b)
 445 -- gaw 2004 FIX?
 446 lift cExpr@(Case expr b _ alts)  =
 447   do
 448     (lExpr, _) <- lift expr
 449     lb    <- liftBinderType  b     -- lift alt-expression
 450     lalts <- if isLit alts
 451                 then extendContext [lb] (liftCaseLit b alts)
 452                 else extendContext [lb] (liftCaseDataCon b alts)
 453     letWrapper lExpr b lalts
 454
 455 lift (Note (Coerce t1 t2) expr) =
 456   do
 457     (lexpr, t) <- lift expr
 458     let lt1 = liftTy t1
 459     return ((Note (Coerce lt1 (liftTy t2)) lexpr), lt1)
 460
 461 lift (Note note expr) =
 462   do
 463     (lexpr, t) <- lift expr
 464     return ((Note note lexpr), t)
 465
 466 lift e@(Type t) = return (e, t)
 467
 468
 469 -- auxilliary functions for lifting of case statements
 470 --
 471
 472 liftCaseDataCon:: CoreBndr -> [Alt CoreBndr] ->
 473        Flatten (([CoreBind], [CoreBind], [CoreBind]))
 474 liftCaseDataCon b [] =
 475   return ([], [], [])
 476 liftCaseDataCon b alls@(alt:alts)
 477   | isDefault alt  =
 478     do
 479       (i,  e,  defAltBndrs) <- liftCaseDataConDefault b alt alts
 480       (is, es, altBndrs)    <- liftCaseDataCon' b alts
 481       return (i:is, e:es, defAltBndrs ++ altBndrs)
 482   | otherwise =
 483     liftCaseDataCon' b alls
 484
 485 liftCaseDataCon':: CoreBndr -> [Alt CoreBndr] ->
 486     Flatten ([CoreBind], [CoreBind], [CoreBind])
 487 liftCaseDataCon' _ [] =
 488   do
 489     return ([], [], [])
 490
 491
 492 liftCaseDataCon' b ((DataAlt dcon, bnds, expr): alts) =
 493   do
 494     (permBnd, exprBnd, packBnd)    <-  liftSingleDataCon b dcon bnds expr
 495     (permBnds, exprBnds, packBnds) <-  liftCaseDataCon' b alts
 496     return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
 497
 498
 499 -- FIXME: is is really necessary to return the binding to the permutation
 500 -- array in the data constructor case, as the representation already
 501 -- contains the extended flag vector
 502 liftSingleDataCon:: CoreBndr -> DataCon -> [CoreBndr] -> CoreExpr ->
 503   Flatten (CoreBind, CoreBind, [CoreBind])
 504 liftSingleDataCon b dcon bnds expr =
 505   do
 506     let dconId           = dataConTag dcon
 507     indexExpr           <- mkIndexOfExprDCon (idType b)  b dconId
 508     (bb, bbind)         <- mkBind FSLIT("is") indexExpr
 509     lbnds               <- mapM liftBinderType bnds
 510     ((lExpr, _), bnds') <- packContext  bb (extendContext lbnds (lift expr))
 511     (_, vbind)          <- mkBind FSLIT("r") lExpr
 512     return (bbind, vbind, bnds')
 513
 514 -- FIXME: clean this up. the datacon and the literal case are so
 515 --   similar that it would be easy to use the same function here
 516 --   instead of duplicating all the code.
 517 --
 518 liftCaseDataConDefault:: CoreBndr -> (Alt CoreBndr) ->  [Alt CoreBndr]
 519   ->  Flatten (CoreBind, CoreBind, [CoreBind])
 520 liftCaseDataConDefault b (_, _, def) alts =
 521   do
 522     let dconIds        = map (\(DataAlt d, _, _) -> dataConTag d) alts
 523     indexExpr         <- mkIndexOfExprDConDft (idType b) b dconIds
 524     (bb, bbind)       <- mkBind FSLIT("is") indexExpr
 525     ((lDef, _), bnds) <- packContext  bb (lift def)
 526     (_, vbind)        <- mkBind FSLIT("r") lDef
 527     return (bbind, vbind, bnds)
 528
 529 -- liftCaseLit: checks if we have a default case and handles it
 530 -- if necessary
 531 liftCaseLit:: CoreBndr -> [Alt CoreBndr] ->
 532        Flatten ([CoreBind], [CoreBind], [CoreBind])
 533 liftCaseLit b [] =
 534     return ([], [], [])    --FIXME: a case with no cases at all???
 535 liftCaseLit b alls@(alt:alts)
 536   | isDefault alt  =
 537     do
 538         (i,  e,  defAltBndrs) <- liftCaseLitDefault b alt alts
 539         (is, es, altBndrs)    <- liftCaseLit' b alts
 540         return (i:is, e:es, defAltBndrs ++ altBndrs)
 541   | otherwise =
 542     do
 543       liftCaseLit' b alls
 544
 545 -- liftCaseLitDefault: looks at all the other alternatives which
 546 --    contain a literal and filters all those elements from the
 547 --    array which do not match any of the literals in the other
 548 --    alternatives.
 549 liftCaseLitDefault:: CoreBndr -> (Alt CoreBndr) ->  [Alt CoreBndr]
 550   ->  Flatten (CoreBind, CoreBind, [CoreBind])
 551 liftCaseLitDefault b (_, _, def) alts =
 552   do
 553     let lits           = map (\(LitAlt l, _, _) -> l) alts
 554     indexExpr         <- mkIndexOfExprDft (idType b) b lits
 555     (bb, bbind)       <- mkBind FSLIT("is") indexExpr
 556     ((lDef, _), bnds) <- packContext  bb (lift def)
 557     (_, vbind)        <- mkBind FSLIT("r") lDef
 558     return (bbind, vbind, bnds)
 559
 560 -- FIXME:
 561 --  Assumption: in case of Lit, the list of binders of the alt is empty.
 562 --
 563 -- returns
 564 --   a list of all vars bound to the expr in the body of the alternative
 565 --   a list of (var, expr) pairs, where var has to be bound to expr
 566 --   by letWrapper
 567 liftCaseLit':: CoreBndr -> [Alt CoreBndr] ->
 568     Flatten ([CoreBind], [CoreBind], [CoreBind])
 569 liftCaseLit' _ [] =
 570   do
 571     return ([], [], [])
 572 liftCaseLit' b ((LitAlt lit, [], expr):alts) =
 573   do
 574     (permBnd, exprBnd, packBnd)    <-  liftSingleCaseLit b lit expr
 575     (permBnds, exprBnds, packBnds) <-  liftCaseLit' b alts
 576     return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
 577
 578 -- lift a single alternative of the form: case  b of lit -> expr.
 579 --
 580 --   It returns the bindings:
 581 --   (a) let b' = indexOfP (mapP (\x -> x == lit) b)
 582 --
 583 --   (b) lift expr in the packed context. Returns lexpr and the
 584 --       list of binds (bnds) that describe the packed arrays
 585 --
 586 --   (c) create new var v' to bind lexpr to
 587 --
 588 --   (d) return (b' = indexOf...., v' = lexpr, bnds)
 589 liftSingleCaseLit:: CoreBndr -> Literal -> CoreExpr  ->
 590   Flatten (CoreBind, CoreBind, [CoreBind])
 591 liftSingleCaseLit b lit expr =
 592  do
 593    indexExpr          <- mkIndexOfExpr (idType b) b lit -- (a)
 594    (bb, bbind)        <- mkBind FSLIT("is") indexExpr
 595    ((lExpr, t), bnds) <- packContext  bb (lift expr)     -- (b)
 596    (_, vbind)         <- mkBind FSLIT("r") lExpr
 597    return (bbind, vbind, bnds)
 598
 599 -- letWrapper lExpr b ([indexbnd_i], [exprbnd_i], [pckbnd_ij])
 600 --
 601 -- let b = lExpr in
 602 --  let index_bnd_1 in
 603 --    let packbnd_11 in
 604 --      ... packbnd_1m in
 605 --         let exprbnd_1 in        ....
 606 --      ...
 607 --          let nvar = replicate dummy (length <current context>)
 608 --               nvar1 = bpermuteDftP index_bnd_1 ...
 609 --
 610 --   in bpermuteDftP index_bnd_n nvar_(n-1)
 611 --
 612 letWrapper:: CoreExpr -> CoreBndr ->([CoreBind], [CoreBind], [CoreBind]) ->
 613   Flatten (CoreExpr, Type)
 614 letWrapper lExpr b (indBnds, exprBnds, pckBnds)  =
 615   do
 616     (defBpBnds, ty) <- dftbpBinders indBnds exprBnds
 617     let resExpr      = getExprOfBind (head defBpBnds)
 618     return ((mkLets (indBnds ++ pckBnds ++ exprBnds ++ defBpBnds) resExpr), ty)
 619
 620 -- dftbpBinders: return the list of binders necessary to construct the overall
 621 --   result from the subresults computed in the different branches of the case
 622 --   statement. The binding which contains the final result is in the *head*
 623 --   of the result list.
 624 --
 625 -- dftbpBinders [ind_i = ...] [expr_i = ...] = [dn = ..., d_n-1 = .., d1 = ...]
 626 --
 627 -- let def = replicate (length of context) undefined
 628 --     d1  = bpermuteDftP dft e1 i1
 629 --     .....
 630 --
 631 dftbpBinders:: [CoreBind] -> [CoreBind] -> Flatten ([CoreBind], Type)
 632 dftbpBinders indexBnds exprBnds =
 633   do
 634     let expr = getExprOfBind (head exprBnds)
 635     defVecExpr     <- createDftArrayBind expr
 636     ((b, bnds), t) <- dftbpBinders' indexBnds exprBnds defVecExpr
 637     return ((b:bnds),t)
 638   where
 639     dftbpBinders' :: [CoreBind]
 640                   -> [CoreBind]
 641                   -> CoreBind
 642                   -> Flatten ((CoreBind, [CoreBind]), Type)
 643     dftbpBinders' [] [] cBnd =
 644       return ((cBnd, []), panic "dftbpBinders: undefined type")
 645     dftbpBinders' (i:is) (e:es) cBind =
 646       do
 647         let iVar = getVarOfBind i
 648         let eVar = getVarOfBind e
 649         let cVar = getVarOfBind cBind
 650         let ty   = idType eVar
 651         newBnd  <- mkDftBackpermute ty iVar eVar cVar
 652         ((fBnd, restBnds), _) <- dftbpBinders' is es newBnd
 653         return ((fBnd, (newBnd:restBnds)), liftTy ty)
 654
 655     dftbpBinders'  _ _ _ =
 656       panic "Flattening.dftbpBinders: index and expression binder lists have different length!"
 657
 658 getExprOfBind:: CoreBind -> CoreExpr
 659 getExprOfBind (NonRec _ expr) = expr
 660
 661 getVarOfBind:: CoreBind -> Var
 662 getVarOfBind (NonRec b _) = b
 663
 664
 665
 666 -- Optimised Transformation
 667 -- =========================
 668 --
 669
 670 -- liftSimpleFun
 671 --   if variables x_1 to x_i occur in the context *and* free in expr
 672 --   then
 673 --   (liftSimpleExpression expr) => mapP (\ (x1,..xn) -> expr) (x1,..xn)
 674 --
 675 liftSimpleFun:: CoreBndr -> CoreExpr -> Flatten (CoreExpr, Type)
 676 liftSimpleFun b expr =
 677   do
 678     bndVars <- collectBoundVars expr
 679     let bndVars'     = b:bndVars
 680         bndVarsTuple = mkTuple (map idType bndVars') (map Var bndVars')
 681         lamExpr      = mkLams (b:bndVars) expr     -- FIXME: should be tuple
 682                                                    -- here
 683     let (t1, t2)     = funTyArgs . exprType $ lamExpr
 684     mapExpr         <-  mk'mapP t1 t2 lamExpr bndVarsTuple
 685     let lexpr        = mkApps mapExpr [bndVarsTuple]
 686     return (lexpr, undefined)                      -- FIXME!!!!!
 687
 688
 689 collectBoundVars:: CoreExpr -> Flatten [CoreBndr]
 690 collectBoundVars  expr =
 691   intersectWithContext (exprFreeVars expr)
 692
 693
 694 -- auxilliary routines
 695 -- -------------------
 696
 697 -- mkIndexOfExpr b lit ->
 698 --   indexOf (mapP (\x -> x == lit) b) b
 699 --
 700 mkIndexOfExpr:: Type -> CoreBndr -> Literal -> Flatten CoreExpr
 701 mkIndexOfExpr  idType b lit =
 702   do
 703     eqExpr        <- mk'eq idType (Var b) (Lit lit)
 704     let lambdaExpr = (Lam b eqExpr)
 705     mk'indexOfP idType  lambdaExpr (Var b)
 706
 707 -- there is FlattenMonad.mk'indexOfP as well as
 708 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
 709
 710 -- for case-distinction over data constructors:
 711 -- let b = expr in
 712 --   case b of
 713 --      dcon args -> ....
 714 -- dconId = dataConTag dcon
 715 -- the call "mkIndexOfExprDCon b dconId" computes the core expression for
 716 -- indexOfP (\x -> x == dconId) b)
 717 --
 718 mkIndexOfExprDCon::Type -> CoreBndr -> Int -> Flatten CoreExpr
 719 mkIndexOfExprDCon  idType b dId =
 720   do
 721     let intExpr    = mkIntLitInt dId
 722     eqExpr        <- mk'eq  idType (Var b) intExpr
 723     let lambdaExpr = (Lam b intExpr)
 724     mk'indexOfP idType lambdaExpr (Var b)
 725
 726
 727
 728 -- there is FlattenMonad.mk'indexOfP as well as
 729 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
 730
 731 -- mk'IndexOfExprDConDft b dconIds : Generates the index expression for the
 732 -- default case. "dconIds" is a list of all the data constructor idents which
 733 -- are covered by the other cases.
 734 -- indexOfP (\x -> x != dconId_1 && ....) b)
 735 --
 736 mkIndexOfExprDConDft:: Type -> CoreBndr -> [Int] -> Flatten CoreExpr
 737 mkIndexOfExprDConDft idType b dId  =
 738   do
 739     let intExprs   = map mkIntLitInt dId
 740     bExpr         <- foldM (mk'neq idType) (head intExprs) (tail intExprs)
 741     let lambdaExpr = (Lam b bExpr)
 742     mk'indexOfP idType (Var b) bExpr
 743
 744
 745 -- mkIndexOfExprDef b [lit1, lit2,...] ->
 746 --   indexOf (\x -> not (x == lit1 || x == lit2 ....) b
 747 mkIndexOfExprDft:: Type -> CoreBndr -> [Literal] -> Flatten CoreExpr
 748 mkIndexOfExprDft idType b lits =
 749   do
 750     let litExprs   = map (\l-> Lit l)  lits
 751     bExpr         <- foldM (mk'neq idType) (head litExprs) (tail litExprs)
 752     let lambdaExpr = (Lam b bExpr)
 753     mk'indexOfP idType bExpr (Var b)
 754
 755
 756 -- create a back-permute binder
 757 --
 758 -- * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a
 759 --   Core binding of the form
 760 --
 761 --     x = bpermuteDftP indexArrayVar srcArrayVar dftArrayVar
 762 --
 763 --   where `x' is a new local variable
 764 --
 765 mkDftBackpermute :: Type -> Var -> Var -> Var -> Flatten CoreBind
 766 mkDftBackpermute ty idx src dft =
 767   do
 768     rhs <- mk'bpermuteDftP ty (Var idx) (Var src) (Var dft)
 769     liftM snd $ mkBind FSLIT("dbp") rhs
 770
 771 -- create a dummy array with elements of the given type, which can be used as
 772 -- default array for the combination of the subresults of the lifted case
 773 -- expression
 774 --
 775 createDftArrayBind    :: CoreExpr -> Flatten CoreBind
 776 createDftArrayBind e  =
 777   panic "Flattening.createDftArrayBind: not implemented yet"
 778 {-
 779   do
 780     let ty = parrElemTy . exprType $ expr
 781     len <- mk'lengthP e
 782     rhs <- mk'replicateP ty len err??
 783     lift snd $ mkBind FSLIT("dft") rhs
 784 FIXME: nicht so einfach; man kann kein "error"-Wert nehmen, denn der w"urde
 785   beim bpermuteDftP sofort evaluiert, aber es ist auch schwer m"oglich einen
 786   generischen Wert f"ur jeden beliebigen Typ zu erfinden.
 787 -}
 788
 789
 790
 791
 792 -- show functions (the pretty print functions sometimes don't
 793 -- show it the way I want....
 794
 795 -- shows just the structure
 796 showCoreExpr (Var _ )    = "Var "
 797 showCoreExpr (Lit _) = "Lit "
 798 showCoreExpr (App e1 e2) =
 799   "(App \n  " ++ (showCoreExpr e1) ++ "\n  " ++ (showCoreExpr e2) ++ ") "
 800 showCoreExpr (Lam b e)   =
 801   "Lam b " ++ (showCoreExpr e)
 802 showCoreExpr (Let bnds expr) =
 803   "Let \n" ++ (showBinds bnds) ++ "in " ++ (showCoreExpr expr)
 804   where showBinds (NonRec b e) = showBind (b,e)
 805         showBinds (Rec bnds)   = concat (map showBind bnds)
 806         showBind (b,e) = "  b = " ++ (showCoreExpr e)++ "\n"
 807 -- gaw 2004 FIX?
 808 showCoreExpr (Case ex b ty alts) =
 809   "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts)
 810   where showAlts _ = ""
 811 showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex)
 812 showCoreExpr (Type t) = "Type"