qute

  1-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>
  2--
  3-- SPDX-License-Identifier: GPL-3.0-only
  4
  5module Language.QBE.Simulator.Default.Generator (generateOperators) where
  6
  7import Language.Haskell.TH
  8
  9data ValueCons
 10  = VWord
 11  | VLong
 12  | VSingle
 13  | VDouble
 14  deriving (Show)
 15
 16toSigned :: ValueCons -> Maybe String
 17toSigned VWord = Just "Int32"
 18toSigned VLong = Just "Int64"
 19toSigned VSingle = Nothing
 20toSigned VDouble = Nothing
 21
 22toSignedExp :: ValueCons -> Exp -> Exp
 23toSignedExp vCons expr =
 24  case toSigned vCons of
 25    Nothing -> expr
 26    Just st ->
 27      let cast = AppE (VarE $ mkName "fromIntegral") expr
 28       in SigE cast (ConT $ mkName st)
 29
 30------------------------------------------------------------------------
 31
 32thBinaryFunc :: Exp -> Exp -> Exp -> Exp
 33thBinaryFunc func lhs = AppE (AppE func lhs)
 34
 35thBinaryOp :: Exp -> Exp -> Exp -> Exp
 36thBinaryOp op = thBinaryFunc (ParensE op)
 37
 38------------------------------------------------------------------------
 39
 40-- Takes an lhs and rhs value and transform it to some 'Exp'.
 41type Transformer = ValueCons -> Exp -> Exp -> Exp
 42
 43applyFunc :: Exp -> ValueCons -> Exp -> Exp -> Exp
 44applyFunc func vCon lhs rhs =
 45  AppE (ConE $ mkName (show vCon)) (thBinaryFunc func lhs rhs)
 46
 47applyOp :: Name -> ValueCons -> Exp -> Exp -> Exp
 48applyOp opName =
 49  applyFunc (ParensE (VarE opName))
 50
 51applySignedOp :: Name -> ValueCons -> Exp -> Exp -> Exp
 52applySignedOp opName vCon lhs rhs =
 53  let lhs' = toSignedExp vCon lhs
 54      rhs' = toSignedExp vCon rhs
 55      cast = AppE (VarE $ mkName "fromIntegral")
 56   in -- TODO: Code duplication with applyFunc
 57      AppE (ConE $ mkName (show vCon)) (cast $ thBinaryFunc (VarE opName) lhs' rhs')
 58
 59applyBoolOp :: Name -> ValueCons -> Exp -> Exp -> Exp
 60applyBoolOp opName _vCons lhs rhs =
 61  let res = thBinaryOp (VarE opName) lhs rhs
 62      toL = AppE (AppE (VarE $ mkName "E.fromLit") (AppE (ConE $ mkName "QBE.Base") (ConE $ mkName "QBE.Long")))
 63   in toL $ CondE res (LitE $ IntegerL 1) (LitE $ IntegerL 0)
 64
 65applySignedBoolOp :: Name -> ValueCons -> Exp -> Exp -> Exp
 66applySignedBoolOp opName vCons lhs rhs =
 67  applyBoolOp opName vCons (toSignedExp vCons lhs) (toSignedExp vCons rhs)
 68
 69------------------------------------------------------------------------
 70
 71operators :: [(Name, Transformer)]
 72operators =
 73  [ (mkName "add'", applyOp (mkName "+")),
 74    (mkName "sub'", applyOp (mkName "-")),
 75    (mkName "mul'", applyOp (mkName "*")),
 76    (mkName "eq'", applyBoolOp (mkName "==")),
 77    (mkName "ne'", applyBoolOp (mkName "/=")),
 78    (mkName "sle'", applySignedBoolOp (mkName "<=")),
 79    (mkName "slt'", applySignedBoolOp (mkName "<")),
 80    (mkName "sge'", applySignedBoolOp (mkName ">=")),
 81    (mkName "sgt'", applySignedBoolOp (mkName ">")),
 82    (mkName "ule'", applyBoolOp (mkName "<=")),
 83    (mkName "ult'", applyBoolOp (mkName "<")),
 84    (mkName "uge'", applyBoolOp (mkName ">=")),
 85    (mkName "ugt'", applyBoolOp (mkName ">"))
 86  ]
 87
 88decOperators :: [(Name, Transformer)]
 89decOperators =
 90  [ (mkName "srem'", applySignedOp (mkName "rem")),
 91    (mkName "urem'", applyOp (mkName "rem")),
 92    (mkName "udiv'", applyOp (mkName "quot")),
 93    (mkName "or'", applyOp (mkName ".|.")),
 94    (mkName "xor'", applyOp (mkName "Data.Bits.xor")),
 95    (mkName "and'", applyOp (mkName ".&."))
 96  ]
 97
 98------------------------------------------------------------------------
 99
100decCons :: [ValueCons]
101decCons = [VWord, VLong]
102
103cons :: [ValueCons]
104cons = decCons ++ [VSingle, VDouble]
105
106makeClause :: Transformer -> ValueCons -> Q Clause
107makeClause trans vCon = do
108  lhs <- newName "lhs"
109  rhs <- newName "rhs"
110
111  let res = trans vCon (VarE lhs) (VarE rhs)
112  let body = AppE (ConE (mkName "Just")) res
113
114  let con = mkName (show vCon)
115  return $
116    Clause
117      [ ConP con [] [VarP lhs],
118        ConP con [] [VarP rhs]
119      ]
120      (NormalB body)
121      []
122
123typingErrorClause :: Clause
124typingErrorClause =
125  Clause
126    [WildP, WildP]
127    (NormalB (ConE $ mkName "Nothing"))
128    []
129
130------------------------------------------------------------------------
131
132genOp :: [ValueCons] -> (Name, Transformer) -> Q Dec
133genOp opLst (name, trans) = do
134  valDefs <- mapM (makeClause trans) opLst
135  return $ FunD name (valDefs ++ [typingErrorClause])
136
137generateOperators :: Q [Dec]
138generateOperators = do
139  o1 <- mapM (genOp cons) operators
140  o2 <- mapM (genOp decCons) decOperators
141  pure $ o1 ++ o2