[commit: ghc] wip/T12618: ConApp: incomplete bytecode support (a184113)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T12618
Link       : http://ghc.haskell.org/trac/ghc/changeset/a184113d96e7e2315c5cf3f800bba3dc2073681e/ghc

>---------------------------------------------------------------

commit a184113d96e7e2315c5cf3f800bba3dc2073681e
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Fri Sep 30 00:10:39 2016 -0400

    ConApp: incomplete bytecode support


>---------------------------------------------------------------

a184113d96e7e2315c5cf3f800bba3dc2073681e
 compiler/ghci/ByteCodeGen.hs | 27 +++++++++++++++++++++++++++
 1 file changed, 27 insertions(+)

diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index 90e2174..33607bd 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -157,6 +157,7 @@ simpleFreeVars = go . freeVars
     go' (AnnLit lit)                 = AnnLit lit
     go' (AnnLam bndr body)           = AnnLam bndr (go body)
     go' (AnnApp fun arg)             = AnnApp (go fun) (go arg)
+    go' (AnnConApp dc args)          = AnnConApp dc (map go args)
     go' (AnnCase scrut bndr ty alts) = AnnCase (go scrut) bndr ty (map go_alt alts)
     go' (AnnLet bind body)           = AnnLet (go_bind bind) (go body)
     go' (AnnCast expr (ann, co))     = AnnCast (go expr) (freeVarsOfAnn ann, co)
@@ -420,6 +421,7 @@ schemeE d s p e
 
 -- Delegate tail-calls to schemeT.
 schemeE d s p e@(AnnApp _ _) = schemeT d s p e
+schemeE d s p e@(AnnConApp _ _) = schemeT d s p e
 
 schemeE d s p e@(AnnLit lit)     = returnUnboxedAtom d s p e (typeArgRep (literalType lit))
 schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
@@ -432,6 +434,7 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
    | (AnnVar v, args_r_to_l) <- splitApp rhs,
      Just data_con <- isDataConWorkId_maybe v,
      dataConRepArity data_con == length args_r_to_l
+     -- TODO #12618 remove eventually
    = do -- Special case for a non-recursive let whose RHS is a
         -- saturatred constructor application.
         -- Just allocate the constructor and carry on
@@ -439,6 +442,14 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
         body_code <- schemeE (d+1) s (Map.insert x d p) body
         return (alloc_code `appOL` body_code)
 
+schemeE d s p (AnnLet (AnnNonRec x (_,AnnConApp dc args)) (_,body))
+   = do -- Special case for a non-recursive let whose RHS is a
+        -- saturatred constructor application.
+        -- Just allocate the constructor and carry on
+        alloc_code <- mkConAppCode d s p dc (map snd (reverse args))
+        body_code <- schemeE (d+1) s (Map.insert x d p) body
+        return (alloc_code `appOL` body_code)
+
 -- General case for let.  Generates correct, if inefficient, code in
 -- all situations.
 schemeE d s p (AnnLet binds (_,body)) = do
@@ -624,6 +635,21 @@ schemeT :: Word         -- Stack depth
         -> AnnExpr' Id DVarSet
         -> BcM BCInstrList
 
+schemeT d s p (AnnConApp dc args')
+   | isUnboxedTupleCon dc
+   = case args of
+        [_,_,arg2,arg1] | isVAtom arg1 ->
+                  unboxedTupleReturn d s p arg2
+        [_,_,arg2,arg1] | isVAtom arg2 ->
+                  unboxedTupleReturn d s p arg1
+        _other -> multiValException
+   | otherwise
+   = do alloc_con <- mkConAppCode d s p dc (reverse args)
+        return (alloc_con         `appOL`
+                mkSLIDE 1 (d - s) `snocOL`
+                ENTER)
+  where args = map snd args'
+
 schemeT d s p app
 
 --   | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
@@ -1605,6 +1631,7 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
 --  d) ticks (but not breakpoints)
 -- Type lambdas *can* occur in random expressions,
 -- whereas value lambdas cannot; that is why they are nuked here
+-- TODO #12618: what to do with data con apps here? Keep types or not?
 bcView (AnnCast (_,e) _)             = Just e
 bcView (AnnLam v (_,e)) | isTyVar v  = Just e
 bcView (AnnApp (_,e) (_, AnnType _)) = Just e