ghc/compiler/ndpFlatten/Flattening.hs

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