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 TcType       ( tcIsForAllTy, tcView )
  67 import TypeRep      ( Type(..) )
  68 import StaticFlags  (opt_Flatten)
  69 import Panic        (panic)
  70 import ErrUtils     (dumpIfSet_dyn)
  71 import UniqSupply   (mkSplitUniqSupply)
  72 import DynFlags  (DynFlag(..))
  73 import Literal      (Literal, literalType)
  74 import Var          (Var(..), idType, isTyVar)
  75 import Id           (setIdType)
  76 import DataCon      (DataCon, dataConTag)
  77 import HscTypes     ( ModGuts(..), ModGuts, HscEnv(..), hscEPS )
  78 import CoreFVs      (exprFreeVars)
  79 import CoreSyn      (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..),
  80                      CoreBndr, CoreExpr, CoreBind, mkLams, mkLets,
  81                      mkApps, mkIntLitInt)
  82 import PprCore      (pprCoreExpr)
  83 import CoreLint     (showPass, endPass)
  84
  85 import CoreUtils    (exprType, applyTypeToArg, mkPiType)
  86 import VarEnv       (zipVarEnv)
  87 import TysWiredIn   (mkTupleTy)
  88 import BasicTypes   (Boxity(..))
  89 import Outputable
  90 import FastString
  91
  92
  93 -- FIXME: fro debugging - remove this
  94 import TRACE    (trace)
  95
  96 -- standard
  97 import Monad        (liftM, foldM)
  98
  99 -- toplevel transformation
 100 -- -----------------------
 101
 102 -- entry point to the flattening transformation for the compiler driver when
 103 -- compiling a complete module (EXPORTED)
 104 --
 105 flatten :: HscEnv
 106         -> ModGuts
 107         -> IO ModGuts
 108 flatten hsc_env mod_impl@(ModGuts {mg_binds = binds})
 109   | not opt_Flatten = return mod_impl -- skip without -fflatten
 110   | otherwise       =
 111   do
 112     let dflags = hsc_dflags hsc_env
 113
 114     eps <- hscEPS hsc_env
 115     us <- mkSplitUniqSupply 'l'         -- 'l' as in fLattening
 116     --
 117     -- announce vectorisation
 118     --
 119     showPass dflags "Flattening [first phase: vectorisation]"
 120     --
 121     -- vectorise all toplevel bindings
 122     --
 123     let binds' = runFlatten hsc_env eps us $ vectoriseTopLevelBinds binds
 124     --
 125     -- and dump the result if requested
 126     --
 127     endPass dflags "Flattening [first phase: vectorisation]"
 128             Opt_D_dump_vect binds'
 129     return $ mod_impl {mg_binds = binds'}
 130
 131 -- entry point to the flattening transformation for the compiler driver when
 132 -- compiling a single expression in interactive mode (EXPORTED)
 133 --
 134 flattenExpr :: HscEnv
 135             -> CoreExpr                 -- the expression to be flattened
 136             -> IO CoreExpr
 137 flattenExpr hsc_env expr
 138   | not opt_Flatten = return expr       -- skip without -fflatten
 139   | otherwise       =
 140   do
 141     let dflags = hsc_dflags hsc_env
 142     eps <- hscEPS hsc_env
 143
 144     us <- mkSplitUniqSupply 'l'         -- 'l' as in fLattening
 145     --
 146     -- announce vectorisation
 147     --
 148     showPass dflags "Flattening [first phase: vectorisation]"
 149     --
 150     -- vectorise the expression
 151     --
 152     let expr' = fst . runFlatten hsc_env eps us $ vectorise expr
 153     --
 154     -- and dump the result if requested
 155     --
 156     dumpIfSet_dyn dflags Opt_D_dump_vect "Vectorised expression"
 157                   (pprCoreExpr expr')
 158     return expr'
 159
 160
 161 -- vectorisation of bindings and expressions
 162 -- -----------------------------------------
 163
 164
 165 vectoriseTopLevelBinds:: [CoreBind] -> Flatten [CoreBind]
 166 vectoriseTopLevelBinds binds =
 167   do
 168     vbinds <- mapM vectoriseBind binds
 169     return (adjustTypeBinds vbinds)
 170
 171 adjustTypeBinds:: [CoreBind] -> [CoreBind]
 172 adjustTypeBinds vbinds =
 173     let
 174        ids = concat (map extIds vbinds)
 175        idEnv =  zipVarEnv ids ids
 176      in map (substIdEnvBind idEnv) vbinds
 177   where
 178     -- FIXME replace by 'bindersOf'
 179     extIds (NonRec b expr) = [b]
 180     extIds (Rec      bnds) = map fst bnds
 181     substIdEnvBind idEnv (NonRec b expr) = NonRec b (substIdEnv idEnv expr)
 182     substIdEnvBind idEnv (Rec bnds)
 183        = Rec (map (\ (b,e) -> (b, (substIdEnv idEnv e))) bnds)
 184
 185 -- vectorise a single core binder
 186 --
 187 vectoriseBind                 :: CoreBind -> Flatten CoreBind
 188 vectoriseBind (NonRec b expr)  =
 189   liftM (NonRec b) $ liftM fst $ vectorise expr
 190 vectoriseBind (Rec bindings)   =
 191   liftM Rec        $ mapM vectoriseOne bindings
 192   where
 193     vectoriseOne (b, expr) =
 194       do
 195         (vexpr, ty) <- vectorise expr
 196         return (setIdType b ty, vexpr)
 197
 198
 199 -- Searches for function definitions and creates a lifted version for
 200 -- each function.
 201 -- We have only two interesting cases:
 202 -- 1) function application  (ex1) (ex2)
 203 --      vectorise both subexpressions. The function will end up becoming a
 204 --      pair (orig. fun, lifted fun), choose first component (in many cases,
 205 --      this is pretty inefficient, since the lifted version is generated
 206 --      although it is clear that it won't be used
 207 --
 208 -- 2) lambda abstraction
 209 --      any function has to exist in two forms: it's original form and it's
 210 --      lifted form. Therefore, every lambda abstraction is transformed into
 211 --      a pair of functions: the original function and its lifted variant
 212 --
 213 --
 214 --  FIXME: currently, I use 'exprType' all over the place - this is terribly
 215 --  inefficient. It should be suffiecient to change 'vectorise' and 'lift' to
 216 --  return the type of the result expression as well.
 217 --
 218 vectorise:: CoreExpr -> Flatten (CoreExpr, Type)
 219 vectorise (Var id)  =
 220   do
 221     let varTy  = idType id
 222     let vecTy  = vectoriseTy varTy
 223     return (Var (setIdType id vecTy), vecTy)
 224
 225 vectorise (Lit lit) =
 226   return ((Lit lit), literalType lit)
 227
 228
 229 vectorise e@(App expr t@(Type _)) =
 230   do
 231     (vexpr, vexprTy) <- vectorise expr
 232     return ((App vexpr t), applyTypeToArg vexprTy t)
 233
 234 vectorise  (App (Lam b expr) arg) =
 235   do
 236     (varg, argTy)    <- vectorise arg
 237     (vexpr, vexprTy) <- vectorise expr
 238     let vb            = setIdType b argTy
 239     return ((App (Lam vb  vexpr) varg),
 240             applyTypeToArg (mkPiType vb vexprTy) varg)
 241
 242 -- if vexpr expects a type as first argument
 243 -- application stays just as it is
 244 --
 245 vectorise (App expr arg) =
 246   do
 247     (vexpr, vexprTy) <-  vectorise expr
 248     (varg,  vargTy)  <-  vectorise arg
 249
 250     if (tcIsForAllTy vexprTy)
 251       then do
 252         let resTy =  applyTypeToArg vexprTy varg
 253         return (App vexpr varg, resTy)
 254       else do
 255         let [t1, t2] = tupleTyArgs  vexprTy
 256         vexpr'      <-  mk'fst t1 t2 vexpr
 257         let resTy    = applyTypeToArg t1 varg
 258         return  ((App vexpr' varg), resTy)  -- apply the first component of
 259                                             -- the vectorized function
 260
 261 vectorise  e@(Lam b expr)
 262   | isTyVar b
 263   =  do
 264         (vexpr, vexprTy) <- vectorise expr          -- don't vectorise 'b'!
 265         return ((Lam b vexpr), mkPiType b vexprTy)
 266   | otherwise =
 267      do
 268        (vexpr, vexprTy)  <- vectorise expr
 269        let vb             = setIdType b (vectoriseTy (idType b))
 270        let ve             =  Lam  vb  vexpr
 271        (lexpr, lexprTy)  <- lift e
 272        let veTy = mkPiType vb vexprTy
 273        return $ (mkTuple [veTy, lexprTy] [ve, lexpr],
 274                  mkTupleTy Boxed 2 [veTy, lexprTy])
 275
 276 vectorise (Let bind body) =
 277   do
 278     vbind            <- vectoriseBind bind
 279     (vbody, vbodyTy) <- vectorise body
 280     return ((Let vbind vbody), vbodyTy)
 281
 282 vectorise (Case expr b ty alts) =
 283   do
 284     (vexpr, vexprTy) <- vectorise expr
 285     valts <- mapM vectorise' alts
 286     let res_ty = snd (head valts)
 287     return (Case vexpr (setIdType b vexprTy) res_ty (map fst valts), res_ty)
 288   where vectorise' (con, bs, expr) =
 289           do
 290             (vexpr, vexprTy) <- vectorise expr
 291             return ((con, bs, vexpr), vexprTy)  -- FIXME: change type of con
 292                                                 --   and bs
 293
 294
 295
 296 vectorise (Note note expr) =
 297  do
 298    (vexpr, vexprTy) <- vectorise expr        -- FIXME: is this ok or does it
 299    return ((Note note vexpr), vexprTy)       --   change the validity of note?
 300
 301 vectorise e@(Type t) =
 302   return (e, t)                              -- FIXME: panic instead of 't'???
 303
 304
 305 {-
 306 myShowTy (TyVarTy _) = "TyVar "
 307 myShowTy (AppTy t1 t2) =
 308   "AppTy (" ++ (myShowTy t1) ++ ", " ++ (myShowTy t2) ++ ")"
 309 myShowTy (TyConApp _ t) =
 310   "TyConApp TC (" ++ (myShowTy t) ++ ")"
 311 -}
 312
 313 vectoriseTy :: Type -> Type
 314 vectoriseTy ty | Just ty' <- tcView ty = vectoriseTy ty'
 315         -- Look through notes and synonyms
 316         -- NB: This will discard notes and synonyms, of course
 317         -- ToDo: retain somehow?
 318 vectoriseTy t@(TyVarTy v)      =  t
 319 vectoriseTy t@(AppTy t1 t2)    =
 320   AppTy (vectoriseTy t1) (vectoriseTy t2)
 321 vectoriseTy t@(TyConApp tc ts) =
 322   TyConApp tc (map vectoriseTy ts)
 323 vectoriseTy t@(FunTy t1 t2)    =
 324   mkTupleTy Boxed 2 [(FunTy (vectoriseTy t1) (vectoriseTy t2)),
 325                      (liftTy t)]
 326 vectoriseTy  t@(ForAllTy v ty)  =
 327   ForAllTy v (vectoriseTy  ty)
 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 ty | Just ty' <- tcView ty = liftTy ty'
 336 liftTy (FunTy t1 t2)   = FunTy (liftTy t1) (liftTy t2)
 337 liftTy (ForAllTy tv t) = ForAllTy tv (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 $  setIdType bndr (liftTy (idType 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, idType 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   | isTyVar 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 -- gaw 2004 FIX?
 442 lift cExpr@(Case expr b _ alts)  =
 443   do
 444     (lExpr, _) <- lift expr
 445     lb    <- liftBinderType  b     -- lift alt-expression
 446     lalts <- if isLit alts
 447                 then extendContext [lb] (liftCaseLit b alts)
 448                 else extendContext [lb] (liftCaseDataCon b alts)
 449     letWrapper lExpr b lalts
 450
 451 lift (Note (Coerce t1 t2) expr) =
 452   do
 453     (lexpr, t) <- lift expr
 454     let lt1 = liftTy t1
 455     return ((Note (Coerce lt1 (liftTy t2)) lexpr), lt1)
 456
 457 lift (Note note expr) =
 458   do
 459     (lexpr, t) <- lift expr
 460     return ((Note note lexpr), t)
 461
 462 lift e@(Type t) = return (e, t)
 463
 464
 465 -- auxilliary functions for lifting of case statements
 466 --
 467
 468 liftCaseDataCon:: CoreBndr -> [Alt CoreBndr] ->
 469        Flatten (([CoreBind], [CoreBind], [CoreBind]))
 470 liftCaseDataCon b [] =
 471   return ([], [], [])
 472 liftCaseDataCon b alls@(alt:alts)
 473   | isDefault alt  =
 474     do
 475       (i,  e,  defAltBndrs) <- liftCaseDataConDefault b alt alts
 476       (is, es, altBndrs)    <- liftCaseDataCon' b alts
 477       return (i:is, e:es, defAltBndrs ++ altBndrs)
 478   | otherwise =
 479     liftCaseDataCon' b alls
 480
 481 liftCaseDataCon':: CoreBndr -> [Alt CoreBndr] ->
 482     Flatten ([CoreBind], [CoreBind], [CoreBind])
 483 liftCaseDataCon' _ [] =
 484   do
 485     return ([], [], [])
 486
 487
 488 liftCaseDataCon' b ((DataAlt dcon, bnds, expr): alts) =
 489   do
 490     (permBnd, exprBnd, packBnd)    <-  liftSingleDataCon b dcon bnds expr
 491     (permBnds, exprBnds, packBnds) <-  liftCaseDataCon' b alts
 492     return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
 493
 494
 495 -- FIXME: is is really necessary to return the binding to the permutation
 496 -- array in the data constructor case, as the representation already
 497 -- contains the extended flag vector
 498 liftSingleDataCon:: CoreBndr -> DataCon -> [CoreBndr] -> CoreExpr ->
 499   Flatten (CoreBind, CoreBind, [CoreBind])
 500 liftSingleDataCon b dcon bnds expr =
 501   do
 502     let dconId           = dataConTag dcon
 503     indexExpr           <- mkIndexOfExprDCon (idType b)  b dconId
 504     (bb, bbind)         <- mkBind FSLIT("is") indexExpr
 505     lbnds               <- mapM liftBinderType bnds
 506     ((lExpr, _), bnds') <- packContext  bb (extendContext lbnds (lift expr))
 507     (_, vbind)          <- mkBind FSLIT("r") lExpr
 508     return (bbind, vbind, bnds')
 509
 510 -- FIXME: clean this up. the datacon and the literal case are so
 511 --   similar that it would be easy to use the same function here
 512 --   instead of duplicating all the code.
 513 --
 514 liftCaseDataConDefault:: CoreBndr -> (Alt CoreBndr) ->  [Alt CoreBndr]
 515   ->  Flatten (CoreBind, CoreBind, [CoreBind])
 516 liftCaseDataConDefault b (_, _, def) alts =
 517   do
 518     let dconIds        = map (\(DataAlt d, _, _) -> dataConTag d) alts
 519     indexExpr         <- mkIndexOfExprDConDft (idType b) b dconIds
 520     (bb, bbind)       <- mkBind FSLIT("is") indexExpr
 521     ((lDef, _), bnds) <- packContext  bb (lift def)
 522     (_, vbind)        <- mkBind FSLIT("r") lDef
 523     return (bbind, vbind, bnds)
 524
 525 -- liftCaseLit: checks if we have a default case and handles it
 526 -- if necessary
 527 liftCaseLit:: CoreBndr -> [Alt CoreBndr] ->
 528        Flatten ([CoreBind], [CoreBind], [CoreBind])
 529 liftCaseLit b [] =
 530     return ([], [], [])    --FIXME: a case with no cases at all???
 531 liftCaseLit b alls@(alt:alts)
 532   | isDefault alt  =
 533     do
 534         (i,  e,  defAltBndrs) <- liftCaseLitDefault b alt alts
 535         (is, es, altBndrs)    <- liftCaseLit' b alts
 536         return (i:is, e:es, defAltBndrs ++ altBndrs)
 537   | otherwise =
 538     do
 539       liftCaseLit' b alls
 540
 541 -- liftCaseLitDefault: looks at all the other alternatives which
 542 --    contain a literal and filters all those elements from the
 543 --    array which do not match any of the literals in the other
 544 --    alternatives.
 545 liftCaseLitDefault:: CoreBndr -> (Alt CoreBndr) ->  [Alt CoreBndr]
 546   ->  Flatten (CoreBind, CoreBind, [CoreBind])
 547 liftCaseLitDefault b (_, _, def) alts =
 548   do
 549     let lits           = map (\(LitAlt l, _, _) -> l) alts
 550     indexExpr         <- mkIndexOfExprDft (idType b) b lits
 551     (bb, bbind)       <- mkBind FSLIT("is") indexExpr
 552     ((lDef, _), bnds) <- packContext  bb (lift def)
 553     (_, vbind)        <- mkBind FSLIT("r") lDef
 554     return (bbind, vbind, bnds)
 555
 556 -- FIXME:
 557 --  Assumption: in case of Lit, the list of binders of the alt is empty.
 558 --
 559 -- returns
 560 --   a list of all vars bound to the expr in the body of the alternative
 561 --   a list of (var, expr) pairs, where var has to be bound to expr
 562 --   by letWrapper
 563 liftCaseLit':: CoreBndr -> [Alt CoreBndr] ->
 564     Flatten ([CoreBind], [CoreBind], [CoreBind])
 565 liftCaseLit' _ [] =
 566   do
 567     return ([], [], [])
 568 liftCaseLit' b ((LitAlt lit, [], expr):alts) =
 569   do
 570     (permBnd, exprBnd, packBnd)    <-  liftSingleCaseLit b lit expr
 571     (permBnds, exprBnds, packBnds) <-  liftCaseLit' b alts
 572     return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds)
 573
 574 -- lift a single alternative of the form: case  b of lit -> expr.
 575 --
 576 --   It returns the bindings:
 577 --   (a) let b' = indexOfP (mapP (\x -> x == lit) b)
 578 --
 579 --   (b) lift expr in the packed context. Returns lexpr and the
 580 --       list of binds (bnds) that describe the packed arrays
 581 --
 582 --   (c) create new var v' to bind lexpr to
 583 --
 584 --   (d) return (b' = indexOf...., v' = lexpr, bnds)
 585 liftSingleCaseLit:: CoreBndr -> Literal -> CoreExpr  ->
 586   Flatten (CoreBind, CoreBind, [CoreBind])
 587 liftSingleCaseLit b lit expr =
 588  do
 589    indexExpr          <- mkIndexOfExpr (idType b) b lit -- (a)
 590    (bb, bbind)        <- mkBind FSLIT("is") indexExpr
 591    ((lExpr, t), bnds) <- packContext  bb (lift expr)     -- (b)
 592    (_, vbind)         <- mkBind FSLIT("r") lExpr
 593    return (bbind, vbind, bnds)
 594
 595 -- letWrapper lExpr b ([indexbnd_i], [exprbnd_i], [pckbnd_ij])
 596 --
 597 -- let b = lExpr in
 598 --  let index_bnd_1 in
 599 --    let packbnd_11 in
 600 --      ... packbnd_1m in
 601 --         let exprbnd_1 in        ....
 602 --      ...
 603 --          let nvar = replicate dummy (length <current context>)
 604 --               nvar1 = bpermuteDftP index_bnd_1 ...
 605 --
 606 --   in bpermuteDftP index_bnd_n nvar_(n-1)
 607 --
 608 letWrapper:: CoreExpr -> CoreBndr ->([CoreBind], [CoreBind], [CoreBind]) ->
 609   Flatten (CoreExpr, Type)
 610 letWrapper lExpr b (indBnds, exprBnds, pckBnds)  =
 611   do
 612     (defBpBnds, ty) <- dftbpBinders indBnds exprBnds
 613     let resExpr      = getExprOfBind (head defBpBnds)
 614     return ((mkLets (indBnds ++ pckBnds ++ exprBnds ++ defBpBnds) resExpr), ty)
 615
 616 -- dftbpBinders: return the list of binders necessary to construct the overall
 617 --   result from the subresults computed in the different branches of the case
 618 --   statement. The binding which contains the final result is in the *head*
 619 --   of the result list.
 620 --
 621 -- dftbpBinders [ind_i = ...] [expr_i = ...] = [dn = ..., d_n-1 = .., d1 = ...]
 622 --
 623 -- let def = replicate (length of context) undefined
 624 --     d1  = bpermuteDftP dft e1 i1
 625 --     .....
 626 --
 627 dftbpBinders:: [CoreBind] -> [CoreBind] -> Flatten ([CoreBind], Type)
 628 dftbpBinders indexBnds exprBnds =
 629   do
 630     let expr = getExprOfBind (head exprBnds)
 631     defVecExpr     <- createDftArrayBind expr
 632     ((b, bnds), t) <- dftbpBinders' indexBnds exprBnds defVecExpr
 633     return ((b:bnds),t)
 634   where
 635     dftbpBinders' :: [CoreBind]
 636                   -> [CoreBind]
 637                   -> CoreBind
 638                   -> Flatten ((CoreBind, [CoreBind]), Type)
 639     dftbpBinders' [] [] cBnd =
 640       return ((cBnd, []), panic "dftbpBinders: undefined type")
 641     dftbpBinders' (i:is) (e:es) cBind =
 642       do
 643         let iVar = getVarOfBind i
 644         let eVar = getVarOfBind e
 645         let cVar = getVarOfBind cBind
 646         let ty   = idType eVar
 647         newBnd  <- mkDftBackpermute ty iVar eVar cVar
 648         ((fBnd, restBnds), _) <- dftbpBinders' is es newBnd
 649         return ((fBnd, (newBnd:restBnds)), liftTy ty)
 650
 651     dftbpBinders'  _ _ _ =
 652       panic "Flattening.dftbpBinders: index and expression binder lists 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 idType 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  idType b lit =
 698   do
 699     eqExpr        <- mk'eq idType (Var b) (Lit lit)
 700     let lambdaExpr = (Lam b eqExpr)
 701     mk'indexOfP idType  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  idType b dId =
 716   do
 717     let intExpr    = mkIntLitInt dId
 718     eqExpr        <- mk'eq  idType (Var b) intExpr
 719     let lambdaExpr = (Lam b intExpr)
 720     mk'indexOfP idType 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 idType b dId  =
 734   do
 735     let intExprs   = map mkIntLitInt dId
 736     bExpr         <- foldM (mk'neq idType) (head intExprs) (tail intExprs)
 737     let lambdaExpr = (Lam b bExpr)
 738     mk'indexOfP idType (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 idType b lits =
 745   do
 746     let litExprs   = map (\l-> Lit l)  lits
 747     bExpr         <- foldM (mk'neq idType) (head litExprs) (tail litExprs)
 748     let lambdaExpr = (Lam b bExpr)
 749     mk'indexOfP idType 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 -- gaw 2004 FIX?
 804 showCoreExpr (Case ex b ty alts) =
 805   "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts)
 806   where showAlts _ = ""
 807 showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex)
 808 showCoreExpr (Type t) = "Type"