@@ -42,15 +42,15 @@ data SAlt = SConCase Int Int Name [Name] SExp
4242data SDecl = SFun Name [Name] Int SExp
4343 deriving Show
4444
45−hvar :: State (DDefs, Int) Int
46−hvar = do (l, h) <- get
47− put (l, h + 1)
48− return h
4945
5046ldefs :: State (DDefs, Int) DDefs
5147ldefs = do (l, h) <- get
5248 return l
5349
50+-- | Simplify an expression by let-binding argument expressions that
51+-- are not variables
52+-- The boolean parameter indicates whether the expression is at tail
53+-- call position.
5454simplify :: Bool -> DExp -> State (DDefs, Int) SExp
5555simplify tl (DV (Loc i)) = return (SV (Loc i))
5656simplify tl (DV (Glob x))
@@ -58,67 +58,62 @@ simplify tl (DV (Glob x))
5858 case lookupCtxtExact x ctxt of
5959 Just (DConstructor _ t 0) -> return $ SCon Nothing t x []
6060 _ -> return $ SV (Glob x)
61−simplify tl (DApp tc n args) = do args' <- mapM sVar args
62− mkapp (SApp (tl || tc) n) args'
61+simplify tl (DApp tc n args) = bindExprs args (SApp (tl || tc) n)
6362simplify tl (DForeign ty fn args)
64− = do args' <- mapM sVar (map snd args)
65− let fargs = zip (map fst args) args'
66− mkfapp (SForeign ty fn) fargs
63+ = let (fdescs, exprs) = unzip args
64+ in bindExprs exprs (\vars -> SForeign ty fn (zip fdescs vars))
6765simplify tl (DLet n v e) = do v' <- simplify False v
6866 e' <- simplify tl e
6967 return (SLet (Glob n) v' e')
7068simplify tl (DUpdate n e) = do e' <- simplify False e
7169 return (SUpdate (Glob n) e')
72−simplify tl (DC loc i n args) = do args' <- mapM sVar args
73− mkapp (SCon loc i n) args'
74−simplify tl (DProj t i) = do v <- sVar t
75− case v of
76− (x, Nothing) -> return (SProj x i)
77− (Glob x, Just e) ->
78− return (SLet (Glob x) e (SProj (Glob x) i))
79−simplify tl (DCase up e alts) = do v <- sVar e
80− alts' <- mapM (sAlt tl) alts
81− case v of
82− (x, Nothing) -> return (SCase up x alts')
83− (Glob x, Just e) ->
84− return (SLet (Glob x) e (SCase up (Glob x) alts'))
70+simplify tl (DC loc i n args) = bindExprs args (SCon loc i n)
71+simplify tl (DProj t i) = bindExpr t (\var -> SProj var i)
72+simplify tl (DCase up e alts)
73+ = do alts' <- mapM (sAlt tl) alts
74+ bindExpr e (\var -> SCase up var alts')
8575simplify tl (DChkCase e alts)
86− = do v <- sVar e
87− alts' <- mapM (sAlt tl) alts
88− case v of
89− (x, Nothing) -> return (SChkCase x alts')
90− (Glob x, Just e) ->
91− return (SLet (Glob x) e (SChkCase (Glob x) alts'))
76+ = do alts' <- mapM (sAlt tl) alts
77+ bindExpr e (\var -> SChkCase var alts')
9278simplify tl (DConst c) = return (SConst c)
93−simplify tl (DOp p args) = do args' <- mapM sVar args
94− mkapp (SOp p) args'
79+simplify tl (DOp p args) = bindExprs args (SOp p)
9580simplify tl DNothing = return SNothing
9681simplify tl (DError str) = return $ SError str
9782
98−sVar (DV (Glob x))
83+
84+-- | Let-bind a list of expressions to variables and construct the
85+-- inner expression with the bound variables.
86+-- If an expression in the list is already a variable we don’t bind it
87+-- again.
88+bindExprs :: [DExp] -> ([LVar] -> SExp) -> State (DDefs, Int) SExp
89+bindExprs es f = bindExprs' es f [] where
90+ bindExprs' [] f vars = return $ f (reverse vars)
91+ bindExprs' (e:es) f vars =
92+ bindExprM e (\var -> bindExprs' es f (var:vars))
93+
94+-- | Special case of 'bindExprs' for just one expression
95+bindExpr :: DExp -> (LVar -> SExp) -> State (DDefs, Int) SExp
96+bindExpr e f = bindExprM e (return . f)
97+
98+bindExprM :: DExp -> (LVar -> State (DDefs, Int) SExp) -> State (DDefs, Int) SExp
99+bindExprM (DV (Glob x)) f
99100 = do ctxt <- ldefs
100101 case lookupCtxtExact x ctxt of
101− Just (DConstructor _ t 0) -> sVar (DC Nothing t x [])
102− _ -> return (Glob x, Nothing)
103−sVar (DV x) = return (x, Nothing)
104−sVar e = do e' <- simplify False e
105− i <- hvar
106− return (Glob (sMN i "R"), Just e')
107−
108−mkapp f args = mkapp' f args [] where
109− mkapp' f [] args = return $ f (reverse args)
110− mkapp' f ((x, Nothing) : xs) args = mkapp' f xs (x : args)
111− mkapp' f ((x, Just e) : xs) args
112− = do sc <- mkapp' f xs (x : args)
113− return (SLet x e sc)
114−
115−mkfapp f args = mkapp' f args [] where
116− mkapp' f [] args = return $ f (reverse args)
117− mkapp' f ((ty, (x, Nothing)) : xs) args = mkapp' f xs ((ty, x) : args)
118− mkapp' f ((ty, (x, Just e)) : xs) args
119− = do sc <- mkapp' f xs ((ty, x) : args)
120− return (SLet x e sc)
121−
102+ Just (DConstructor _ t 0) -> bindExprM (DC Nothing t x []) f
103+ _ -> f (Glob x)
104+bindExprM (DV var) f = f var
105+bindExprM e f =
106+ do e' <- simplify False e
107+ var <- freshVar
108+ f' <- f var
109+ return $ SLet var e' f'
110+ where
111+ freshVar = do (defs, i) <- get
112+ put (defs, i + 1)
113+ return (Glob (sMN i "R"))
114+
115+
116+sAlt :: Bool -> DAlt -> State (DDefs, Int) SAlt
122117sAlt tl (DConCase i n args e) = do e' <- simplify tl e
123118 return (SConCase (-1) i n args e')
124119sAlt tl (DConstCase c e) = do e' <- simplify tl e