diff --git a/rtree-c/src/ReduceC.hs b/rtree-c/src/ReduceC.hs
index f2bcefc9cd5aae81c8ec2cd282e19780aad58b35..9159349ab9601d9d6a81b9361b4f3cacc036c0d3 100644
--- a/rtree-c/src/ReduceC.hs
+++ b/rtree-c/src/ReduceC.hs
@@ -1137,13 +1137,18 @@ etUnPointer t =
checkNotAssignable :: (MonadPlus m) => EType -> m ()
checkNotAssignable = guard . not . etAssignable
-msplit :: (MonadReduce Lab m) => Lab -> Maybe (m a) -> Maybe (m a) -> Maybe (m a)
-msplit l m1 m2 = do
- case m1 of
- Just a -> Just $ case m2 of
- Just b -> split l a b
- Nothing -> a
- Nothing -> m2
+msplit :: (MonadReduce Lab m) => Context -> Lab -> Maybe (m a) -> Maybe (m a) -> Maybe (m a)
+msplit ctx l m1 m2
+ | DontRepairExpressions `isIn` ctx = do
+ b <- m2
+ Just $ case m1 of
+ Just a -> split l a b
+ Nothing -> b
+ | otherwise = case m1 of
+ Just a -> Just $ case m2 of
+ Just b -> split l a b
+ Nothing -> a
+ Nothing -> m2
{-# INLINE msplit #-}
inferType :: Context -> C.CExpr -> Maybe Voidable
@@ -1218,8 +1223,8 @@ reduceCExpr ::
Maybe (m C.CExpr)
reduceCExpr expr t ctx = case expr of
C.CBinary o elhs erhs ni -> do
- msplit ("reduce to left", C.posOf elhs) (reduceCExpr elhs t ctx) do
- msplit ("reduce to right", C.posOf erhs) (reduceCExpr erhs t ctx) do
+ msplit ctx ("reduce to left", C.posOf elhs) (reduceCExpr elhs t ctx) do
+ msplit ctx ("reduce to right", C.posOf erhs) (reduceCExpr erhs t ctx) do
checkNotAssignable t
when (o `elem` [C.CNeqOp, C.CEqOp, C.CGeqOp, C.CLeqOp, C.CGrOp, C.CLeOp]) do
checkExpectedType ctx (NonVoid TNum) t
@@ -1242,8 +1247,8 @@ reduceCExpr expr t ctx = case expr of
_ow -> r'
pure $ C.CBinary o l' r'' ni
C.CAssign o elhs erhs ni ->
- msplit ("reduce to left", C.posOf elhs) (reduceCExpr elhs t ctx) do
- msplit ("reduce to right", C.posOf erhs) (reduceCExpr erhs t ctx) do
+ msplit ctx ("reduce to left", C.posOf elhs) (reduceCExpr elhs t ctx) do
+ msplit ctx ("reduce to right", C.posOf erhs) (reduceCExpr erhs t ctx) do
c <- inferType ctx elhs
checkExpectedType ctx c t
let t' = fromVoid etAny exactly c
@@ -1284,7 +1289,7 @@ reduceCExpr expr t ctx = case expr of
checkExpectedType ctx (NonVoid TNum) t
Just (pure expr)
C.CUnary o eopr ni -> do
- msplit ("reduce to operant", C.posOf eopr) (reduceCExpr eopr t ctx) do
+ msplit ctx ("reduce to operant", C.posOf eopr) (reduceCExpr eopr t ctx) do
case o of
C.CIndOp -> do
ropr <- case etSet t of
@@ -1309,38 +1314,38 @@ reduceCExpr expr t ctx = case expr of
reduceCExpr eopr t ctx <&> \ropr -> do
eopr' <- ropr
pure $ C.CUnary o eopr' ni
- C.CCall ef args ni -> do
- (\fn a -> foldr fn a args)
- (\e -> msplit ("reduce to expression", C.posOf e) (reduceCExpr e t ctx))
- do
- ct <- inferType ctx ef
- case ct of
- NonVoid ft@(TFun (FunType rt fargs)) -> do
- checkNotAssignable t
- checkExpectedType ctx rt t
- ref <- reduceCExpr ef (exactly ft) ctx
- let targs = case fargs of
- Params targs' v ->
- let cons = if v then repeat (Just ETAny) else []
- in map (fmap ETExactly) targs' <> cons
- VoidParams -> repeat (Just ETAny)
- let pargs = mapMaybe (\(ta, a) -> (,a) <$> ta) (zip targs args)
- rargs <- forM pargs \(ta, a) ->
- reduceCExpr a (EType ta False) ctx
- Just do
- ef' <- ref
- args' <- sequence rargs
- pure $ C.CCall ef' args' ni
- ow -> do
- error $
- "Original c code does not type-check: exepected function, got "
- <> show ow
- <> " at "
- <> show (C.posOf ef)
+ C.CCall ef args ni -> orHoistSubExpression do
+ ct <- inferType ctx ef
+ case ct of
+ NonVoid ft@(TFun (FunType rt fargs)) -> do
+ checkNotAssignable t
+ checkExpectedType ctx rt t
+ ref <- reduceCExpr ef (exactly ft) ctx
+ let targs = case fargs of
+ Params targs' v ->
+ let cons = if v then repeat (Just ETAny) else []
+ in map (fmap ETExactly) targs' <> cons
+ VoidParams -> repeat (Just ETAny)
+ let pargs = mapMaybe (\(ta, a) -> (,a) <$> ta) (zip targs args)
+ rargs <- forM pargs \(ta, a) ->
+ reduceCExpr a (EType ta False) ctx
+ Just do
+ ef' <- ref
+ args' <- sequence rargs
+ pure $ C.CCall ef' args' ni
+ ow -> do
+ error $
+ "Original c code does not type-check: exepected function, got "
+ <> show ow
+ <> " at "
+ <> show (C.posOf ef)
+ where
+ orHoistSubExpression a =
+ foldr (\e -> msplit ctx ("reduce to expression", C.posOf e) (reduceCExpr e t ctx)) a args
C.CCond et (Just ec) ef ni -> do
- msplit ("reduce to true branch", C.posOf et) (reduceCExpr et t ctx) do
- msplit ("reduce to false branch", C.posOf ef) (reduceCExpr ef t ctx) do
- msplit ("reduce to condtion", C.posOf ef) (reduceCExpr ec t ctx) do
+ msplit ctx ("reduce to true branch", C.posOf et) (reduceCExpr et t ctx) do
+ msplit ctx ("reduce to false branch", C.posOf ef) (reduceCExpr ef t ctx) do
+ msplit ctx ("reduce to condtion", C.posOf ef) (reduceCExpr ec t ctx) do
checkNotAssignable t
ret <- reduceCExpr et t ctx
ref <- reduceCExpr ef t ctx
@@ -1351,7 +1356,7 @@ reduceCExpr expr t ctx = case expr of
ec' <- rec
pure $ C.CCond et' (Just ec') ef' ni
C.CCast (C.CDecl spec items ni2) e ni -> do
- msplit ("do not cast", C.posOf ni) (reduceCExpr e t ctx) do
+ msplit ctx ("do not cast", C.posOf ni) (reduceCExpr e t ctx) do
fn <- updateCDeclarationSpecifiers keepAll ctx spec
hole <- case items of
[C.CDeclarationItem (C.CDeclr Nothing dd Nothing [] a) b c] -> do
@@ -1372,8 +1377,8 @@ reduceCExpr expr t ctx = case expr of
(spec', items', e') <- hole
pure (C.CCast (C.CDecl spec' items' ni2) e' ni)
C.CIndex e1 e2 ni -> do
- msplit ("reduce to indexee", C.posOf e1) (reduceCExpr e1 t ctx) do
- msplit ("reduce to index", C.posOf e2) (reduceCExpr e2 t ctx) do
+ msplit ctx ("reduce to indexee", C.posOf e1) (reduceCExpr e1 t ctx) do
+ msplit ctx ("reduce to index", C.posOf e2) (reduceCExpr e2 t ctx) do
re1 <- reduceCExpr e1 t{etSet = ETPointer (etSet t), etAssignable = True} ctx
Just do
e1' <- re1
@@ -1384,7 +1389,7 @@ reduceCExpr expr t ctx = case expr of
C.CComma items ni -> do
(x, rst) <- List.uncons (reverse items)
(\fn a -> foldr fn a (reverse items))
- (\e -> msplit ("reduce to expression", C.posOf e) (reduceCExpr e t ctx))
+ (\e -> msplit ctx ("reduce to expression", C.posOf e) (reduceCExpr e t ctx))
do
rx <- reduceCExpr x t ctx
Just do
@@ -1480,6 +1485,7 @@ data Keyword
| AllowEmptyDeclarations
| DontReduceArrays
| DontRemoveStatic
+ | DontRepairExpressions
| DisallowVariableInlining
| AllowInfiniteForLoops
deriving (Show, Read, Enum, Eq, Ord)