summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorPéter Diviánszky <divipp@gmail.com>2016-05-14 01:40:54 +0200
committerPéter Diviánszky <divipp@gmail.com>2016-05-14 01:40:54 +0200
commit472c3b8d66c3f3065e8a6715c59c5295cb16d435 (patch)
tree46578cc49b2084bd6a8945bd3ab7612baa10d7bc /src
parentfeeac006f966a7e2d621985d9c3eb2c45d2dbdb0 (diff)
refactoring
Diffstat (limited to 'src')
-rw-r--r--src/LambdaCube/Compiler/Core.hs128
-rw-r--r--src/LambdaCube/Compiler/DesugaredSource.hs5
2 files changed, 70 insertions, 63 deletions
diff --git a/src/LambdaCube/Compiler/Core.hs b/src/LambdaCube/Compiler/Core.hs
index ecc8cf07..3fca8b45 100644
--- a/src/LambdaCube/Compiler/Core.hs
+++ b/src/LambdaCube/Compiler/Core.hs
@@ -462,76 +462,75 @@ instance MkDoc Neutral where
462 MT "finElim" [m, z, s, n, ConN "FZero" [i]] -> z `app_` i 462 MT "finElim" [m, z, s, n, ConN "FZero" [i]] -> z `app_` i
463-} 463-}
464 464
465mkFunDef a@(show -> "primFix") t = fn 465mkFunDef a@(FTag FprimFix) t = fn
466 where 466 where
467 fn = FunName a 0 (DeltaDef (length $ fst $ getParams t) fx) t 467 fn = FunName a 0 (DeltaDef (length $ fst $ getParams t) fx) t
468 fx s xs = Neut $ Fun_ s fn xs $ case xs of 468 fx s xs = Neut $ Fun_ s fn xs $ case xs of
469 f: _{-1-} -> RHS x where x = f `app_` Neut (Fun_ s fn xs $ RHS x) 469 f: _{-1-} -> RHS x where x = f `app_` Neut (Fun_ s fn xs $ RHS x)
470 _ -> delta 470 _ -> delta
471 471
472mkFunDef a t = fn 472mkFunDef a@(FTag tag) t = fn
473 where
474 fn = FunName a 0 (maybe NoDef (DeltaDef (length $ fst $ getParams t) . const) $ getFunDef t a $ \xs -> Neut $ Fun fn xs delta) t
475
476-- TODO: don't use show?
477getFunDef t s f = case show s of
478 "'EqCT" -> Just $ \case (b: a: t: _) -> cstr t a b
479 "'T2" -> Just $ \case (b: a: _) -> t2 a b
480 "'CW" -> Just $ \case (a: _) -> cw a
481 "t2C" -> Just $ \case (b: a: _) -> t2C a b
482 "coe" -> Just $ \case (d: t: b: a: _) -> evalCoe a b t d
483 "parEval" -> Just $ \case (b: a: t: _) -> parEval t a b
484 where
485 parEval _ x@RHS{} _ = x
486 parEval _ _ x@RHS{} = x
487 parEval t a b = ParEval t a b
488
489 "unsafeCoerce" -> Just $ \case xs@(x@(hnf -> NonNeut): _{-2-}) -> x; xs -> f xs
490 "reflCstr" -> Just $ \case _ -> TT
491 "hlistNilCase" -> Just $ \case ((hnf -> Con n@(ConName _ 0 _) _ _): x: _{-1-}) -> x; xs -> f xs
492 "hlistConsCase" -> Just $ \case ((hnf -> Con n@(ConName _ 1 _) _ (b: a: _{-2-})): x: _{-3-}) -> x `app_` a `app_` b; xs -> f xs
493
494 -- general compiler primitives
495 "primAddInt" -> Just $ \case (HInt j: HInt i: _) -> HInt (i + j); xs -> f xs
496 "primSubInt" -> Just $ \case (HInt j: HInt i: _) -> HInt (i - j); xs -> f xs
497 "primModInt" -> Just $ \case (HInt j: HInt i: _) -> HInt (i `mod` j); xs -> f xs
498 "primSqrtFloat" -> Just $ \case (HFloat i: _) -> HFloat $ sqrt i; xs -> f xs
499 "primRound" -> Just $ \case (HFloat i: _) -> HInt $ round i; xs -> f xs
500 "primIntToFloat" -> Just $ \case (HInt i: _) -> HFloat $ fromIntegral i; xs -> f xs
501 "primIntToNat" -> Just $ \case (HInt i: _) -> ENat $ fromIntegral i; xs -> f xs
502 "primCompareInt" -> Just $ \case (HInt y: HInt x: _) -> mkOrdering $ x `compare` y; xs -> f xs
503 "primCompareFloat" -> Just $ \case (HFloat y: HFloat x: _) -> mkOrdering $ x `compare` y; xs -> f xs
504 "primCompareChar" -> Just $ \case (HChar y: HChar x: _) -> mkOrdering $ x `compare` y; xs -> f xs
505 "primCompareString" -> Just $ \case (HString y: HString x: _) -> mkOrdering $ x `compare` y; xs -> f xs
506
507 -- LambdaCube 3D specific primitives
508 "PrimGreaterThan" -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (>) x y -> r; xs -> f xs
509 "PrimGreaterThanEqual"
510 -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (>=) x y -> r; xs -> f xs
511 "PrimLessThan" -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (<) x y -> r; xs -> f xs
512 "PrimLessThanEqual" -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (<=) x y -> r; xs -> f xs
513 "PrimEqualV" -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (==) x y -> r; xs -> f xs
514 "PrimNotEqualV" -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (/=) x y -> r; xs -> f xs
515 "PrimEqual" -> Just $ \case (y: x: _{-3-}) | Just r <- twoOpBool (==) x y -> r; xs -> f xs
516 "PrimNotEqual" -> Just $ \case (y: x: _{-3-}) | Just r <- twoOpBool (/=) x y -> r; xs -> f xs
517 "PrimSubS" -> Just $ \case (y: x: _{-4-}) | Just r <- twoOp (-) x y -> r; xs -> f xs
518 "PrimSub" -> Just $ \case (y: x: _{-2-}) | Just r <- twoOp (-) x y -> r; xs -> f xs
519 "PrimAddS" -> Just $ \case (y: x: _{-4-}) | Just r <- twoOp (+) x y -> r; xs -> f xs
520 "PrimAdd" -> Just $ \case (y: x: _{-2-}) | Just r <- twoOp (+) x y -> r; xs -> f xs
521 "PrimMulS" -> Just $ \case (y: x: _{-4-}) | Just r <- twoOp (*) x y -> r; xs -> f xs
522 "PrimMul" -> Just $ \case (y: x: _{-2-}) | Just r <- twoOp (*) x y -> r; xs -> f xs
523 "PrimDivS" -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ (/) div x y -> r; xs -> f xs
524 "PrimDiv" -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ (/) div x y -> r; xs -> f xs
525 "PrimModS" -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ modF mod x y -> r; xs -> f xs
526 "PrimMod" -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ modF mod x y -> r; xs -> f xs
527 "PrimNeg" -> Just $ \case (x: _{-1-}) | Just r <- oneOp negate x -> r; xs -> f xs
528 "PrimAnd" -> Just $ \case (EBool y: EBool x: _) -> EBool (x && y); xs -> f xs
529 "PrimOr" -> Just $ \case (EBool y: EBool x: _) -> EBool (x || y); xs -> f xs
530 "PrimXor" -> Just $ \case (EBool y: EBool x: _) -> EBool (x /= y); xs -> f xs
531 "PrimNot" -> Just $ \case (EBool x: _: _: (hnf -> TNat): _) -> EBool $ not x; xs -> f xs
532
533 _ -> Nothing
534 where 473 where
474 f xs = Neut $ Fun fn xs delta
475 fn = FunName a 0 (maybe NoDef (DeltaDef (length $ fst $ getParams t) . const) $ getFunDef tag) t
476
477 getFunDef = \case
478 F'EqCT -> Just $ \case (b: a: t: _) -> cstr t a b
479 F'T2 -> Just $ \case (b: a: _) -> t2 a b
480 F'CW -> Just $ \case (a: _) -> cw a
481 Ft2C -> Just $ \case (b: a: _) -> t2C a b
482 Fcoe -> Just $ \case (d: t: b: a: _) -> evalCoe a b t d
483 FparEval -> Just $ \case (b: a: t: _) -> parEval t a b
484 where
485 parEval _ x@RHS{} _ = x
486 parEval _ _ x@RHS{} = x
487 parEval t a b = ParEval t a b
488
489 FunsafeCoerce -> Just $ \case xs@(x@(hnf -> NonNeut): _{-2-}) -> x; xs -> f xs
490 FreflCstr -> Just $ \case _ -> TT
491 FhlistNilCase -> Just $ \case ((hnf -> Con n@(ConName _ 0 _) _ _): x: _{-1-}) -> x; xs -> f xs
492 FhlistConsCase -> Just $ \case ((hnf -> Con n@(ConName _ 1 _) _ (b: a: _{-2-})): x: _{-3-}) -> x `app_` a `app_` b; xs -> f xs
493
494 -- general compiler primitives
495 FprimAddInt -> Just $ \case (HInt j: HInt i: _) -> HInt (i + j); xs -> f xs
496 FprimSubInt -> Just $ \case (HInt j: HInt i: _) -> HInt (i - j); xs -> f xs
497 FprimModInt -> Just $ \case (HInt j: HInt i: _) -> HInt (i `mod` j); xs -> f xs
498 FprimSqrtFloat -> Just $ \case (HFloat i: _) -> HFloat $ sqrt i; xs -> f xs
499 FprimRound -> Just $ \case (HFloat i: _) -> HInt $ round i; xs -> f xs
500 FprimIntToFloat -> Just $ \case (HInt i: _) -> HFloat $ fromIntegral i; xs -> f xs
501 FprimIntToNat -> Just $ \case (HInt i: _) -> ENat $ fromIntegral i; xs -> f xs
502 FprimCompareInt -> Just $ \case (HInt y: HInt x: _) -> mkOrdering $ x `compare` y; xs -> f xs
503 FprimCompareFloat -> Just $ \case (HFloat y: HFloat x: _) -> mkOrdering $ x `compare` y; xs -> f xs
504 FprimCompareChar -> Just $ \case (HChar y: HChar x: _) -> mkOrdering $ x `compare` y; xs -> f xs
505 FprimCompareString -> Just $ \case (HString y: HString x: _) -> mkOrdering $ x `compare` y; xs -> f xs
506
507 -- LambdaCube 3D specific primitives
508 FPrimGreaterThan -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (>) x y -> r; xs -> f xs
509 FPrimGreaterThanEqual
510 -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (>=) x y -> r; xs -> f xs
511 FPrimLessThan -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (<) x y -> r; xs -> f xs
512 FPrimLessThanEqual -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (<=) x y -> r; xs -> f xs
513 FPrimEqualV -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (==) x y -> r; xs -> f xs
514 FPrimNotEqualV -> Just $ \case (y: x: _{-7-}) | Just r <- twoOpBool (/=) x y -> r; xs -> f xs
515 FPrimEqual -> Just $ \case (y: x: _{-3-}) | Just r <- twoOpBool (==) x y -> r; xs -> f xs
516 FPrimNotEqual -> Just $ \case (y: x: _{-3-}) | Just r <- twoOpBool (/=) x y -> r; xs -> f xs
517 FPrimSubS -> Just $ \case (y: x: _{-4-}) | Just r <- twoOp (-) x y -> r; xs -> f xs
518 FPrimSub -> Just $ \case (y: x: _{-2-}) | Just r <- twoOp (-) x y -> r; xs -> f xs
519 FPrimAddS -> Just $ \case (y: x: _{-4-}) | Just r <- twoOp (+) x y -> r; xs -> f xs
520 FPrimAdd -> Just $ \case (y: x: _{-2-}) | Just r <- twoOp (+) x y -> r; xs -> f xs
521 FPrimMulS -> Just $ \case (y: x: _{-4-}) | Just r <- twoOp (*) x y -> r; xs -> f xs
522 FPrimMul -> Just $ \case (y: x: _{-2-}) | Just r <- twoOp (*) x y -> r; xs -> f xs
523 FPrimDivS -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ (/) div x y -> r; xs -> f xs
524 FPrimDiv -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ (/) div x y -> r; xs -> f xs
525 FPrimModS -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ modF mod x y -> r; xs -> f xs
526 FPrimMod -> Just $ \case (y: x: _{-5-}) | Just r <- twoOp_ modF mod x y -> r; xs -> f xs
527 FPrimNeg -> Just $ \case (x: _{-1-}) | Just r <- oneOp negate x -> r; xs -> f xs
528 FPrimAnd -> Just $ \case (EBool y: EBool x: _) -> EBool (x && y); xs -> f xs
529 FPrimOr -> Just $ \case (EBool y: EBool x: _) -> EBool (x || y); xs -> f xs
530 FPrimXor -> Just $ \case (EBool y: EBool x: _) -> EBool (x /= y); xs -> f xs
531 FPrimNot -> Just $ \case (EBool x: _: _: (hnf -> TNat): _) -> EBool $ not x; xs -> f xs
532
533 _ -> Nothing
535 534
536 twoOpBool :: (forall a . Ord a => a -> a -> Bool) -> Exp -> Exp -> Maybe Exp 535 twoOpBool :: (forall a . Ord a => a -> a -> Bool) -> Exp -> Exp -> Maybe Exp
537 twoOpBool f (HFloat x) (HFloat y) = Just $ EBool $ f x y 536 twoOpBool f (HFloat x) (HFloat y) = Just $ EBool $ f x y
@@ -557,6 +556,9 @@ getFunDef t s f = case show s of
557 556
558 modF x y = x - fromIntegral (floor (x / y)) * y 557 modF x y = x - fromIntegral (floor (x / y)) * y
559 558
559mkFunDef a t = FunName a 0 NoDef t
560
561
560evalCaseFun _ a ps (Con n@(ConName _ i _) _ vs) 562evalCaseFun _ a ps (Con n@(ConName _ i _) _ vs)
561 | i /= (-1) = foldlrev app_ (ps !!! (i + 1)) vs 563 | i /= (-1) = foldlrev app_ (ps !!! (i + 1)) vs
562 | otherwise = error "evcf" 564 | otherwise = error "evcf"
diff --git a/src/LambdaCube/Compiler/DesugaredSource.hs b/src/LambdaCube/Compiler/DesugaredSource.hs
index c02fc7ca..db2c1f24 100644
--- a/src/LambdaCube/Compiler/DesugaredSource.hs
+++ b/src/LambdaCube/Compiler/DesugaredSource.hs
@@ -210,6 +210,11 @@ data FNameTag
210 -- functions 210 -- functions
211 | Fcoe | FparEval | Ft2C | FprimFix 211 | Fcoe | FparEval | Ft2C | FprimFix
212 | Fparens | FtypeAnn | Fundefined | Fotherwise | FprimIfThenElse | FfromTo | FconcatMap | FfromInt | Fproject | Fswizzscalar | Fswizzvector 212 | Fparens | FtypeAnn | Fundefined | Fotherwise | FprimIfThenElse | FfromTo | FconcatMap | FfromInt | Fproject | Fswizzscalar | Fswizzvector
213
214 | FunsafeCoerce | FreflCstr | FhlistNilCase | FhlistConsCase
215 | FprimAddInt | FprimSubInt | FprimModInt | FprimSqrtFloat | FprimRound | FprimIntToFloat | FprimIntToNat | FprimCompareInt | FprimCompareFloat | FprimCompareChar | FprimCompareString
216 | FPrimGreaterThan | FPrimGreaterThanEqual | FPrimLessThan | FPrimLessThanEqual | FPrimEqualV | FPrimNotEqualV | FPrimEqual | FPrimNotEqual | FPrimSubS | FPrimSub | FPrimAddS | FPrimAdd | FPrimMulS | FPrimMul | FPrimDivS | FPrimDiv | FPrimModS | FPrimMod | FPrimNeg | FPrimAnd | FPrimOr | FPrimXor | FPrimNot
217
213 -- other 218 -- other
214 | F_rhs | F_section 219 | F_rhs | F_section
215 deriving (Eq, Ord, Show, Enum, Bounded) 220 deriving (Eq, Ord, Show, Enum, Bounded)
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-02 14:08:58 +0000