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 -- standard
  56 import Monad        (liftM, foldM)
  57
  58 -- GHC
  59 import CmdLineOpts  (opt_Flatten)
  60 import Panic        (panic)
  61 import ErrUtils     (dumpIfSet_dyn)
  62 import UniqSupply   (UniqSupply, mkSplitUniqSupply)
  63 import CmdLineOpts  (DynFlag(..), DynFlags)
  64 import Literal      (Literal, literalType)
  65 import Var          (Var(..),TyVar)
  66 import DataCon      (DataCon, dataConTag)
  67 import TypeRep      (Type(..))
  68 import Type         (isTypeKind)
  69 import HscTypes     (HomeSymbolTable, PersistentCompilerState, ModDetails(..))
  70 import CoreFVs      (exprFreeVars)
  71 import CoreSyn      (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..),
  72                      CoreBndr, CoreExpr, CoreBind, CoreAlt, mkLams, mkLets,
  73                      mkApps, mkIntLitInt)
  74 import PprCore      (pprCoreExpr)
  75 import CoreLint     (showPass, endPass)
  76
  77 import CoreUtils    (exprType, applyTypeToArg, mkPiType)
  78 import VarEnv       (IdEnv, mkVarEnv, zipVarEnv, extendVarEnv)
  79 import TysWiredIn   (mkTupleTy)
  80 import BasicTypes   (Boxity(..))
  81 import Outputable   (showSDoc, Outputable(..))
  82
  83
  84 -- friends
  85 import NDPCoreUtils (tupleTyArgs, funTyArgs, parrElemTy, isDefault,
  86                      isLit, mkPArrTy, mkTuple, isSimpleExpr, boolTy, substIdEnv)
  87 import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext,
  88                      liftVar, liftConst, intersectWithContext, mk'fst,
  89                      mk'lengthP, mk'replicateP, mk'mapP, mk'bpermuteDftP,
  90                      mk'indexOfP,mk'eq,mk'neq)
  91
  92 -- FIXME: fro debugging - remove this
  93 import IOExts    (trace)
  94
  95
  96 #include "HsVersions.h"
  97 {-# INLINE slit #-}
  98 slit x = FastString.mkFastCharString# x
  99 -- FIXME: SLIT() doesn't work for some strange reason
 100
 101
 102 -- toplevel transformation
 103 -- -----------------------
 104
 105 -- entry point to the flattening transformation for the compiler driver when
 106 -- compiling a complete module (EXPORTED)
 107 --
 108 flatten :: DynFlags
 109         -> PersistentCompilerState
 110         -> HomeSymbolTable
 111         -> ModDetails                   -- the module to be flattened
 112         -> IO ModDetails
 113 flatten dflags pcs hst modDetails@(ModDetails {md_binds = binds})
 114   | not opt_Flatten = return modDetails -- skip without -fflatten
 115   | otherwise       =
 116   do
 117     us <- mkSplitUniqSupply 'l'         -- 'l' as in fLattening
 118     --
 119     -- announce vectorisation
 120     --
 121     showPass dflags "Flattening [first phase: vectorisation]"
 122     --
 123     -- vectorise all toplevel bindings
 124     --
 125     let binds' = runFlatten pcs hst us $ vectoriseTopLevelBinds binds
 126     --
 127     -- and dump the result if requested
 128     --
 129     endPass dflags "Flattening [first phase: vectorisation]"
 130             Opt_D_dump_vect binds'
 131     return $ modDetails {md_binds = binds'}
 132
 133 -- entry point to the flattening transformation for the compiler driver when
 134 -- compiling a single expression in interactive mode (EXPORTED)
 135 --
 136 flattenExpr :: DynFlags
 137             -> PersistentCompilerState
 138             -> HomeSymbolTable
 139             -> CoreExpr                 -- the expression to be flattened
 140             -> IO CoreExpr
 141 flattenExpr dflags pcs hst expr
 142   | not opt_Flatten = return expr       -- skip without -fflatten
 143   | otherwise       =
 144   do
 145     us <- mkSplitUniqSupply 'l'         -- 'l' as in fLattening
 146     --
 147     -- announce vectorisation
 148     --
 149     showPass dflags "Flattening [first phase: vectorisation]"
 150     --
 151     -- vectorise the expression
 152     --
 153     let expr' = fst . runFlatten pcs hst us $ vectorise expr
 154     --
 155     -- and dump the result if requested
 156     --
 157     dumpIfSet_dyn dflags Opt_D_dump_vect "Vectorised expression"
 158                   (pprCoreExpr expr')
 159     return expr'
 160
 161
 162 -- vectorisation of bindings and expressions
 163 -- -----------------------------------------
 164
 165
 166 vectoriseTopLevelBinds:: [CoreBind] -> Flatten [CoreBind]
 167 vectoriseTopLevelBinds binds =
 168   do
 169     vbinds <- mapM vectoriseBind binds
 170     return (adjustTypeBinds vbinds)
 171
 172 adjustTypeBinds:: [CoreBind] -> [CoreBind]
 173 adjustTypeBinds vbinds =
 174     let
 175        ids = concat (map extIds vbinds)
 176        idEnv =  zipVarEnv ids ids
 177      in map (substIdEnvBind idEnv) vbinds
 178   where
 179     -- FIXME replace by 'bindersOf'
 180     extIds (NonRec b expr) = [b]
 181     extIds (Rec      bnds) = map fst bnds
 182     substIdEnvBind idEnv (NonRec b expr) = NonRec b (substIdEnv idEnv expr)
 183     substIdEnvBind idEnv (Rec bnds)
 184        = Rec (map (\ (b,e) -> (b, (substIdEnv idEnv e))) bnds)
 185
 186 -- vectorise a single core binder
 187 --
 188 vectoriseBind                 :: CoreBind -> Flatten CoreBind
 189 vectoriseBind (NonRec b expr)  =
 190   liftM (NonRec b) $ liftM fst $ vectorise expr
 191 vectoriseBind (Rec bindings)   =
 192   liftM Rec        $ mapM vectoriseOne bindings
 193   where
 194     vectoriseOne (b, expr) =
 195       do
 196         (vexpr, ty) <- vectorise expr
 197         return (b{varType = ty}, vexpr)
 198
 199
 200 -- Searches for function definitions and creates a lifted version for
 201 -- each function.
 202 -- We have only two interesting cases:
 203 -- 1) function application  (ex1) (ex2)
 204 --      vectorise both subexpressions. The function will end up becoming a
 205 --      pair (orig. fun, lifted fun), choose first component (in many cases,
 206 --      this is pretty inefficient, since the lifted version is generated
 207 --      although it is clear that it won't be used
 208 --
 209 -- 2) lambda abstraction
 210 --      any function has to exist in two forms: it's original form and it's
 211 --      lifted form. Therefore, every lambda abstraction is transformed into
 212 --      a pair of functions: the original function and its lifted variant
 213 --
 214 --
 215 --  FIXME: currently, I use 'exprType' all over the place - this is terribly
 216 --  inefficient. It should be suffiecient to change 'vectorise' and 'lift' to
 217 --  return the type of the result expression as well.
 218 --
 219 vectorise:: CoreExpr -> Flatten (CoreExpr, Type)
 220 vectorise (Var id)  =
 221   do
 222     let varTy  = varType id
 223     let vecTy  = vectoriseTy varTy
 224     return ((Var id{varType = vecTy}), vecTy)
 225
 226 vectorise (Lit lit) =
 227   return ((Lit lit), literalType lit)
 228
 229
 230 vectorise e@(App expr t@(Type _)) =
 231   do
 232     (vexpr, vexprTy) <- vectorise expr
 233     return ((App vexpr t), applyTypeToArg vexprTy t)
 234
 235 vectorise  (App (Lam b expr) arg) =
 236   do
 237     (varg, argTy)    <- vectorise arg
 238     (vexpr, vexprTy) <- vectorise expr
 239     let vb            = b{varType = argTy}
 240     return ((App (Lam vb  vexpr) varg),
 241             applyTypeToArg (mkPiType vb vexprTy) varg)
 242
 243 -- if vexpr expects a type as first argument
 244 -- application stays just as it is
 245 --
 246 vectorise (App expr arg) =
 247   do
 248     (vexpr, vexprTy) <-  vectorise expr
 249     (varg,  vargTy)  <-  vectorise arg
 250
 251     if (isPolyType vexprTy)
 252       then do
 253         let resTy =  applyTypeToArg vexprTy varg
 254         return (App vexpr varg, resTy)
 255       else do
 256         let [t1, t2] = tupleTyArgs  vexprTy
 257         vexpr'      <-  mk'fst t1 t2 vexpr
 258         let resTy    = applyTypeToArg t1 varg
 259         return  ((App vexpr' varg), resTy)  -- apply the first component of
 260                                             -- the vectorized function
 261   where
 262     isPolyType t =
 263         (case t  of
 264            (ForAllTy _ _)  -> True
 265            (NoteTy _ nt)   -> isPolyType nt
 266            _               -> False)
 267
 268
 269 vectorise  e@(Lam b expr)
 270   | isTypeKind (varType b) =
 271       do
 272         (vexpr, vexprTy) <- vectorise expr          -- don't vectorise 'b'!
 273         return ((Lam b vexpr), mkPiType b vexprTy)
 274   | otherwise =
 275      do
 276        (vexpr, vexprTy)  <- vectorise expr
 277        let vb             = b{varType = vectoriseTy (varType b)}
 278        let ve             =  Lam  vb  vexpr
 279        (lexpr, lexprTy)  <- lift e
 280        let veTy = mkPiType vb vexprTy
 281        return $ (mkTuple [veTy, lexprTy] [ve, lexpr],
 282                  mkTupleTy Boxed 2 [veTy, lexprTy])
 283
 284 vectorise (Let bind body) =
 285   do
 286     vbind            <- vectoriseBind bind
 287     (vbody, vbodyTy) <- vectorise body
 288     return ((Let vbind vbody), vbodyTy)
 289
 290 vectorise (Case expr b alts) =
 291   do
 292     (vexpr, vexprTy) <- vectorise expr
 293     valts <- mapM vectorise' alts
 294     return (Case vexpr b{varType = vexprTy} (map fst valts), snd (head valts))
 295   where vectorise' (con, bs, expr) =
 296           do
 297             (vexpr, vexprTy) <- vectorise expr
 298             return ((con, bs, vexpr), vexprTy)  -- FIXME: change type of con
 299                                                 --   and bs
 300
 301
 302
 303 vectorise (Note note expr) =
 304  do
 305    (vexpr, vexprTy) <- vectorise expr        -- FIXME: is this ok or does it
 306    return ((Note note vexpr), vexprTy)       --   change the validity of note?
 307
 308 vectorise e@(Type t) =
 309   return (e, t)                              -- FIXME: panic instead of 't'???
 310
 311
 312 {-
 313 myShowTy (TyVarTy _) = "TyVar "
 314 myShowTy (AppTy t1 t2) =
 315   "AppTy (" ++ (myShowTy t1) ++ ", " ++ (myShowTy t2) ++ ")"
 316 myShowTy (TyConApp _ t) =
 317   "TyConApp TC (" ++ (myShowTy t) ++ ")"
 318 -}
 319
 320 vectoriseTy :: Type -> Type
 321 vectoriseTy t@(TyVarTy v)      =  t
 322 vectoriseTy t@(AppTy t1 t2)    =
 323   AppTy (vectoriseTy t1) (vectoriseTy t2)
 324 vectoriseTy t@(TyConApp tc ts) =
 325   TyConApp tc (map vectoriseTy ts)
 326 vectoriseTy t@(FunTy t1 t2)    =
 327   mkTupleTy Boxed 2 [(FunTy (vectoriseTy t1) (vectoriseTy t2)),
 328                      (liftTy t)]
 329 vectoriseTy  t@(ForAllTy v ty)  =
 330   ForAllTy v (vectoriseTy  ty)
 331 vectoriseTy t@(NoteTy note ty) =  -- FIXME: is the note still valid after
 332   NoteTy note  (vectoriseTy ty)   --   this or should we just throw it away
 333 vectoriseTy  t =  t
 334
 335
 336 -- liftTy: wrap the type in an array but be careful with function types
 337 --    on the *top level* (is this sufficient???)
 338
 339 liftTy:: Type -> Type
 340 liftTy (FunTy t1 t2)   = FunTy (liftTy t1) (liftTy t2)
 341 liftTy (ForAllTy tv t) = ForAllTy tv (liftTy t)
 342 liftTy (NoteTy n t)    = NoteTy n $ liftTy t
 343 liftTy  t              = mkPArrTy t
 344
 345
 346 --  lifting:
 347 -- ----------
 348 --  * liftType
 349 --  * lift
 350
 351
 352 -- liftBinderType: Converts a  type 'a' stored in the binder to the
 353 -- representation of '[:a:]' will therefore call liftType
 354 --
 355 --  lift type, don't change name (incl unique) nor IdInfo. IdInfo looks ok,
 356 --  but I'm not entirely sure about some fields (e.g., strictness info)
 357 liftBinderType:: CoreBndr ->  Flatten CoreBndr
 358 liftBinderType bndr = return $  bndr {varType = liftTy (varType bndr)}
 359
 360 -- lift: lifts an expression (a -> [:a:])
 361 -- If the expression is a simple expression, it is treated like a constant
 362 -- expression.
 363 -- If the body of a lambda expression is a simple expression, it is
 364 -- transformed into a mapP
 365 lift:: CoreExpr -> Flatten (CoreExpr, Type)
 366 lift cExpr@(Var id)    =
 367   do
 368     lVar@(Var lId) <- liftVar id
 369     return (lVar, varType lId)
 370
 371 lift cExpr@(Lit lit)   =
 372   do
 373     lLit  <- liftConst cExpr
 374     return (lLit, exprType lLit)
 375
 376
 377 lift (Lam b expr)
 378   | isSimpleExpr expr      =  liftSimpleFun b expr
 379   | isTypeKind (varType b) =
 380     do
 381       (lexpr, lexprTy) <- lift expr  -- don't lift b!
 382       return (Lam b lexpr, mkPiType b lexprTy)
 383   | otherwise =
 384     do
 385       lb               <- liftBinderType b
 386       (lexpr, lexprTy) <- extendContext [lb] (lift expr)
 387       return ((Lam lb lexpr) , mkPiType lb lexprTy)
 388
 389 lift (App expr1 expr2) =
 390   do
 391     (lexpr1, lexpr1Ty) <- lift expr1
 392     (lexpr2, _)        <- lift expr2
 393     return ((App lexpr1 lexpr2), applyTypeToArg lexpr1Ty lexpr2)
 394
 395
 396 lift (Let (NonRec b expr1) expr2)
 397   |isSimpleExpr expr2 =
 398     do
 399       (lexpr1, _)        <- lift expr1
 400       (lexpr2, lexpr2Ty) <- liftSimpleFun b expr2
 401       let (t1, t2) = funTyArgs lexpr2Ty
 402       liftM (\x -> (x, liftTy t2)) $  mk'mapP t1 t2 lexpr2 lexpr1
 403
 404   | otherwise =
 405     do
 406       (lexpr1, _)        <- lift expr1
 407       lb                 <- liftBinderType b
 408       (lexpr2, lexpr2Ty) <- extendContext [lb] (lift expr1)
 409       return ((Let (NonRec lb lexpr1) lexpr2), lexpr2Ty)
 410
 411 lift (Let (Rec binds) expr2) =
 412   do
 413     let (bndVars, exprs)  = unzip binds
 414     lBndVars           <- mapM liftBinderType bndVars
 415     lexprs             <- extendContext bndVars (mapM lift exprs)
 416     (lexpr2, lexpr2Ty) <- extendContext bndVars (lift expr2)
 417     return ((Let (Rec (zip  lBndVars (map fst lexprs))) lexpr2), lexpr2Ty)
 418
 419 -- FIXME:
 420 -- Assumption: alternatives can either be literals or data construtors.
 421 --             Due to type restrictions, I don't think it is possible
 422 --             that they are mixed.
 423 --             The handling of literals and data constructors is completely
 424 --             different
 425 --
 426 --
 427 -- let b = expr in alts
 428 --
 429 -- I think I read somewhere that the default case (if present) is stored
 430 -- in the head of the list. Assume for now this is true, have to check
 431 --
 432 -- (1) literals
 433 -- (2) data constructors
 434 --
 435 -- FIXME: optimisation: first, filter out all simple expression and
 436 --   loop (mapP & filter) over all the corresponding values in a single
 437 --   traversal:
 438
 439 --    (1) splitAlts:: [Alt CoreBndr] -> ([Alt CoreBndr],[Alt CoreBndr])
 440 --                                       simple alts     reg alts
 441 --    (2) if simpleAlts = [] then (just as before)
 442 --        if regAlts    = [] then (the whole thing is just a loop)
 443 --        otherwise (a) compute index vector for simpleAlts (for def permute
 444 --                      later on
 445 --                  (b)
 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 (varType b)  b dconId
 508     (b', bbind)         <- mkBind (slit "is"#) indexExpr
 509     lbnds               <- mapM liftBinderType bnds
 510     ((lExpr, _), bnds') <- packContext  b' (extendContext lbnds (lift expr))
 511     (_, vbind)          <- mkBind (slit "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 (varType b) b dconIds
 524     (b', bbind)       <- mkBind (slit "is"#) indexExpr
 525     ((lDef, _), bnds) <- packContext  b' (lift def)
 526     (_, vbind)        <- mkBind (slit "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 (varType b) b lits
 555     (b', bbind)       <- mkBind (slit "is"#) indexExpr
 556     ((lDef, _), bnds) <- packContext  b' (lift def)
 557     (_, vbind)        <- mkBind (slit "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 (varType b) b lit -- (a)
 594    (b', bbind)        <- mkBind (slit "is"#) indexExpr
 595    ((lExpr, t), bnds) <- packContext  b' (lift expr)     -- (b)
 596    (_, vbind)         <- mkBind (slit "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   = varType 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 \
 657             \have different length!"
 658
 659 getExprOfBind:: CoreBind -> CoreExpr
 660 getExprOfBind (NonRec _ expr) = expr
 661
 662 getVarOfBind:: CoreBind -> Var
 663 getVarOfBind (NonRec b _) = b
 664
 665
 666
 667 -- Optimised Transformation
 668 -- =========================
 669 --
 670
 671 -- liftSimpleFun
 672 --   if variables x_1 to x_i occur in the context *and* free in expr
 673 --   then
 674 --   (liftSimpleExpression expr) => mapP (\ (x1,..xn) -> expr) (x1,..xn)
 675 --
 676 liftSimpleFun:: CoreBndr -> CoreExpr -> Flatten (CoreExpr, Type)
 677 liftSimpleFun b expr =
 678   do
 679     bndVars <- collectBoundVars expr
 680     let bndVars'     = b:bndVars
 681         bndVarsTuple = mkTuple (map varType bndVars') (map Var bndVars')
 682         lamExpr      = mkLams (b:bndVars) expr     -- FIXME: should be tuple
 683                                                    -- here
 684     let (t1, t2)     = funTyArgs . exprType $ lamExpr
 685     mapExpr         <-  mk'mapP t1 t2 lamExpr bndVarsTuple
 686     let lexpr        = mkApps mapExpr [bndVarsTuple]
 687     return (lexpr, undefined)                      -- FIXME!!!!!
 688
 689
 690 collectBoundVars:: CoreExpr -> Flatten [CoreBndr]
 691 collectBoundVars  expr =
 692   intersectWithContext (exprFreeVars expr)
 693
 694
 695 -- auxilliary routines
 696 -- -------------------
 697
 698 -- mkIndexOfExpr b lit ->
 699 --   indexOf (mapP (\x -> x == lit) b) b
 700 --
 701 mkIndexOfExpr:: Type -> CoreBndr -> Literal -> Flatten CoreExpr
 702 mkIndexOfExpr  varType b lit =
 703   do
 704     eqExpr        <- mk'eq  varType (Var b) (Lit lit)
 705     let lambdaExpr = (Lam b eqExpr)
 706     mk'indexOfP varType  lambdaExpr (Var b)
 707
 708 -- there is FlattenMonad.mk'indexOfP as well as
 709 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
 710
 711 -- for case-distinction over data constructors:
 712 -- let b = expr in
 713 --   case b of
 714 --      dcon args -> ....
 715 -- dconId = dataConTag dcon
 716 -- the call "mkIndexOfExprDCon b dconId" computes the core expression for
 717 -- indexOfP (\x -> x == dconId) b)
 718 --
 719 mkIndexOfExprDCon::Type -> CoreBndr -> Int -> Flatten CoreExpr
 720 mkIndexOfExprDCon  varType b dId =
 721   do
 722     let intExpr    = mkIntLitInt dId
 723     eqExpr        <- mk'eq  varType (Var b) intExpr
 724     let lambdaExpr = (Lam b intExpr)
 725     mk'indexOfP varType lambdaExpr (Var b)
 726
 727
 728
 729 -- there is FlattenMonad.mk'indexOfP as well as
 730 -- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here
 731
 732 -- mk'IndexOfExprDConDft b dconIds : Generates the index expression for the
 733 -- default case. "dconIds" is a list of all the data constructor idents which
 734 -- are covered by the other cases.
 735 -- indexOfP (\x -> x != dconId_1 && ....) b)
 736 --
 737 mkIndexOfExprDConDft:: Type -> CoreBndr -> [Int] -> Flatten CoreExpr
 738 mkIndexOfExprDConDft varType b dId  =
 739   do
 740     let intExprs   = map mkIntLitInt dId
 741     bExpr         <- foldM (mk'neq varType) (head intExprs) (tail intExprs)
 742     let lambdaExpr = (Lam b bExpr)
 743     mk'indexOfP varType (Var b) bExpr
 744
 745
 746 -- mkIndexOfExprDef b [lit1, lit2,...] ->
 747 --   indexOf (\x -> not (x == lit1 || x == lit2 ....) b
 748 mkIndexOfExprDft:: Type -> CoreBndr -> [Literal] -> Flatten CoreExpr
 749 mkIndexOfExprDft varType b lits =
 750   do
 751     let litExprs   = map (\l-> Lit l)  lits
 752     bExpr         <- foldM (mk'neq varType) (head litExprs) (tail litExprs)
 753     let lambdaExpr = (Lam b bExpr)
 754     mk'indexOfP varType bExpr (Var b)
 755
 756
 757 -- create a back-permute binder
 758 --
 759 -- * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a
 760 --   Core binding of the form
 761 --
 762 --     x = bpermuteDftP indexArrayVar srcArrayVar dftArrayVar
 763 --
 764 --   where `x' is a new local variable
 765 --
 766 mkDftBackpermute :: Type -> Var -> Var -> Var -> Flatten CoreBind
 767 mkDftBackpermute ty idx src dft =
 768   do
 769     rhs <- mk'bpermuteDftP ty (Var idx) (Var src) (Var dft)
 770     liftM snd $ mkBind (slit "dbp"#) rhs
 771
 772 -- create a dummy array with elements of the given type, which can be used as
 773 -- default array for the combination of the subresults of the lifted case
 774 -- expression
 775 --
 776 createDftArrayBind    :: CoreExpr -> Flatten CoreBind
 777 createDftArrayBind e  =
 778   panic "Flattening.createDftArrayBind: not implemented yet"
 779 {-
 780   do
 781     let ty = parrElemTy . exprType $ expr
 782     len <- mk'lengthP e
 783     rhs <- mk'replicateP ty len err??
 784     lift snd $ mkBind (slit "dft"#) rhs
 785 FIXME: nicht so einfach; man kann kein "error"-Wert nehmen, denn der w"urde
 786   beim bpermuteDftP sofort evaluiert, aber es ist auch schwer m"oglich einen
 787   generischen Wert f"ur jeden beliebigen Typ zu erfinden.
 788 -}
 789
 790
 791
 792
 793 -- show functions (the pretty print functions sometimes don't
 794 -- show it the way I want....
 795
 796 -- shows just the structure
 797 showCoreExpr (Var _ )    = "Var "
 798 showCoreExpr (Lit _) = "Lit "
 799 showCoreExpr (App e1 e2) =
 800   "(App \n  " ++ (showCoreExpr e1) ++ "\n  " ++ (showCoreExpr e2) ++ ") "
 801 showCoreExpr (Lam b e)   =
 802   "Lam b " ++ (showCoreExpr e)
 803 showCoreExpr (Let bnds expr) =
 804   "Let \n" ++ (showBinds bnds) ++ "in " ++ (showCoreExpr expr)
 805   where showBinds (NonRec b e) = showBind (b,e)
 806         showBinds (Rec bnds)   = concat (map showBind bnds)
 807         showBind (b,e) = "  b = " ++ (showCoreExpr e)++ "\n"
 808 showCoreExpr (Case ex b 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"