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