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